diff --git a/.hlint.yaml b/.hlint.yaml index f12dfd72c..5414d2724 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -12,6 +12,7 @@ - ignore: { name: "Use ***" } - ignore: { name: "Redundant void" } - ignore: { name: "Too strict maybe" } + - ignore: { name: "Use Just" } - arguments: - -XQuasiQuotes diff --git a/CHANGELOG.md b/CHANGELOG.md index 67e64602c..e6b2999fa 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,107 @@ 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. +## [20.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.1...v20.6.0) (2020-10-06) + + +### Features + +* **study-features:** cache study features term relevance ([8f6d54d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8f6d54d0125e01f5c8a90843b54129d6412b79f1)) + + +### Bug Fixes + +* **study-features:** also apply caching to table columns ([564c0b9](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/564c0b975ae65881cb3a168855b36e4b1614a6cb)) + +### [20.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.0...v20.5.1) (2020-09-29) + + +### Bug Fixes + +* **exams:** default exam mode to Nothing ([4b459ea](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4b459ea1430a4947364562f1a9881596325696ad)) + +## [20.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.1...v20.5.0) (2020-09-28) + + +### Features + +* **allocations:** notify about new courses ([18921e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18921e06d1deeb41d705eabacc2d348bac76197f)) +* **allocations:** show staff descriptions ([b359468](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b35946859309fbb526043194c8620c5fc0844809)) +* **changelog:** implement changelog like faq ([d9d353f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d9d353fcb7652c46a15016b5d2f400162c8271ef)) +* **exams:** check exam_discouraged_modes ([f9c50c8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9c50c80f22770f5376396923b8921eaac3e7216)) +* **exams:** exam design & school exam rules ([f7bab3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f7bab3befc4c42cde430699681f8caf8a959ab39)) + + +### Bug Fixes + +* tests ([65e0688](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65e06882d2491da5e30b1401db6ecc81efcac58b)) +* **allocations:** notify for new course upon registration ([9e0b43a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e0b43a60d26a05f6e1b9d4dae2b2f75dd52fff1)) +* tests ([ca81f3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca81f3b0f2913431cbaf399c33ed30a21979ce69)) + +### [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23) + + +### Bug Fixes + +* **metrics:** larger range for worker_state_duration ([34a5265](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/34a52653d71140bcc664cbe864cad069441b5c6e)) + +## [20.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.2...v20.4.0) (2020-09-23) + + +### Features + +* **files:** monitor missing files ([fb0ae65](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fb0ae65ac5928443abc01de9b57c69849d6a6b21)) + + +### Bug Fixes + +* **jobs:** better flushing, correct metrics, better etas ([e4416e7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e4416e7f0e2ea2cf9db0e61cf2d20c27260ccaf8)) + +### [20.3.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.1...v20.3.2) (2020-09-22) + + +### Bug Fixes + +* **files:** don't inject serializable ([2ca024b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2ca024b9351df800b57d3235c4a00776cd669952)) + +### [20.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.3.0...v20.3.1) (2020-09-22) + + +### Bug Fixes + +* **jobs:** improve job worker healthchecks & logging ([2a84edc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2a84edccb4cdfddc2bdc03ebdd2b934fd7f53884)) + +## [20.3.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.2.0...v20.3.0) (2020-09-21) + + +### Features + +* **jobs:** move held-up jobs to different workers ([284aae1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/284aae12135ad97b1cf85b45f1176da6930876ee)) + +## [20.2.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.1...v20.2.0) (2020-09-21) + + +### Features + +* **logging:** additional logging for inject-files ([cbf41b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbf41b2ea061aa276f455dde1e31464d106cd3d7)) +* improve logging/metrics wrt. batch jobs ([d21faf4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d21faf4de0d40a3683ff2a7a3020bc85717f827c)) +* **metrics:** measure file i/o ([4801d22](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4801d22cb360dcd936c57494ff2ff02655431409)) + + +### Bug Fixes + +* **exam-form:** sort occurrences and parts ([6d47549](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6d475497c0caee49ad34c5c3c6e7b1bf91ca0ba2)) + +### [20.1.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.1.0...v20.1.1) (2020-09-18) + + +### Bug Fixes + +* **file-jobs:** improve log messages ([e099e13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e099e13816d2ca79cbcc6a84fe970052980c0feb)) +* **jobs:** delimit resource allocation to within handler ([7038099](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7038099389fcca684a9e1a3f28f76629e0c194bd)) +* **metrics:** sort metrics ([e5ae152](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/e5ae1521a0577df35abe13b6bcc602f3a38a6f9c)) +* migration ([dd23559](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/dd235590b47a90d70753458ffc7ab61c771f3d9b)) + ## [20.1.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.0.0...v20.1.0) (2020-09-17) diff --git a/config/settings.yml b/config/settings.yml index d8b8b0330..9524f75b2 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -26,7 +26,8 @@ mail-support: job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" job-cron-interval: "_env:CRON_INTERVAL:60" -job-stale-threshold: 300 +job-stale-threshold: 1800 +job-move-threshold: 30 notification-rate-limit: 3600 notification-collate-delay: 7200 notification-expiration: 259200 @@ -160,8 +161,8 @@ upload-cache: disable-cert-validation: "_env:UPLOAD_S3_DISABLE_CERT_VALIDATION:false" upload-cache-bucket: "uni2work-uploads" -inject-files: 307 -rechunk-files: 601 +inject-files: 601 +rechunk-files: 1201 file-upload-db-chunksize: 4194304 # 4MiB file-chunking-target-exponent: 21 # 2MiB diff --git a/frontend/src/app.sass b/frontend/src/app.sass index d8c5f6e5d..a05048445 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -637,6 +637,11 @@ section &.notification--broad max-width: none + &:first-child + margin-top: 0 + &:last-child + margin-bottom: 0 + .form-section-notification display: grid grid-template-columns: 1fr 3fr @@ -1109,9 +1114,8 @@ th, td pointer-events: none #changelog - font-size: 14px - white-space: pre-wrap - font-family: var(--font-monospace) + max-height: 75vh + overflow: auto #gitrev font-size: 12px diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d02d9acd1..f3ae33d80 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -810,6 +810,15 @@ FormBehaviour: Verhalten FormCosmetics: Oberfläche FormPersonalAppearance: Öffentliche Daten FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen +FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse +FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen" + +AllocNotifyNewCourseDefault: Systemweite Einstellung +AllocNotifyNewCourseForceOff: Nein +AllocNotifyNewCourseForceOn: Ja + +BtnNotifyNewCourseForceOn: Benachrichtigen +BtnNotifyNewCourseForceOff: Nicht benachrichtigen PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt. PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt. @@ -1153,6 +1162,8 @@ NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs an NotificationTriggerSubmissionUserCreated: Ich wurde als Mitabgebender zu einer Übungsblatt-Abgabe hinzugefügt NotificationTriggerSubmissionEdited: Eine meiner Übungsblatt-Abgaben wurde verändert NotificationTriggerSubmissionUserDeleted: Ich wurde als Mitabgebender von einer Übungsblatt-Abgabe entfernt +NotificationTriggerAllocationNewCourse: Es wurde ein neuer Kurs eingetragen zu einer Zentralanmeldungen, zu der ich meine Teilnahme registriert habe +NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden NotificationTriggerKindAll: Für alle Benutzer NotificationTriggerKindCourseParticipant: Für Kursteilnehmer @@ -1852,6 +1863,39 @@ ExamFormOccurrences: Prüfungstermine/Räume ExamFormAutomaticFunctions: Automatische Funktionen ExamFormCorrection: Korrektur ExamFormParts: Teile +ExamFormMode: Ausgestaltung der Prüfung + +ExamModeFormNone: Keine Angabe +ExamModeFormCustom: Benutzerdefiniert +ExamModeFormAids: Erlaubte Hilfsmittel +ExamModeFormOnline: Online/Offline +ExamModeFormSynchronicity: Synchron/Asynchron +ExamModeFormRequiredEquipment: Erforderliche Hilfsmittel +ExamModeFormRequiredEquipmentIdentificationTip: Es wird stets ein Hinweis angezeigt, dass Teilnehmer sich ausweisen können müssen. + +ExamShowAids: Erlaubte Hilfsmittel +ExamShowOnline: Online/Offline +ExamShowSynchronicity: Synchron/Asynchron +ExamShowRequiredEquipment: Erforderliche Hilfsmittel +ExamShowRequiredEquipmentNoneSet: Keine Angabe durch die Kursverwalter +ExamShowIdentificationRequired: Prüfungsteilnehmer müssen sich ausweisen können. Halten Sie dafür einen amtlichen Lichtbildausweis (Personalausweis, Reisepass, Aufenthaltstitel) und Ihren Studierendenausweis bereit. + +ExamOpenBook: Open Book +ExamClosedBook: Closed Book + +ExamOnline: Online +ExamOffline: Offline + +ExamSynchronous: Synchron +ExamAsynchronous: Asynchron + +ExamRequiredEquipmentNone: Nichts +ExamRequiredEquipmentPen: Stift +ExamRequiredEquipmentPaperPen: Stift & Papier +ExamRequiredEquipmentCalculatorPen: Stift & Taschenrechner +ExamRequiredEquipmentCalculatorPaperPen: Stift, Papier & Taschenrechner +ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & Mikrophon +ExamRequiredEquipmentMicrophoneInternet: Mikrophon ExamCorrectors: Korrektoren ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen. @@ -1904,6 +1948,10 @@ ExamFinishedMustBeAfterStart: "Ergebnisse sichtbar ab" muss nach Beginn liegen ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Ergebnisse sichtbar ab" liegen ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Beginn liegen ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen +ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Beginn" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen. +ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen. +ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann. +ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen @@ -2223,6 +2271,13 @@ ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter ApplicationRatingSection: Bewertung ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren. +AllocationNotificationNewCourse: Benachrichtigung bei neuen Kursen +AllocationNotificationNewCourseTip: Wollen Sie per E-Mail benachrichtigt werden, wenn für diese Zentralanmeldung ein neuer Kurs eingetragen wird? Dies überschreibt die systemweite Einstellung in "Anpassen". +AllocationNotificationNewCourseSuccessForceOn: Sie werden benachrichtigt, wenn ein neuer Kurs eingetragen wird +AllocationNotificationNewCourseSuccessForceOff: Sie werden nicht benachrichtigt, wenn ein neuer Kurs eingetragen wird +AllocationNotificationNewCourseCurrentlyOff: Aktuell würden Sie keine Benachrichtigung erhalten. +AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt werden. +AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein. AllocationSchoolShort: Institut Allocation: Zentralanmeldung @@ -2253,6 +2308,13 @@ SchoolName: Name SchoolLdapOrganisations: Assoziierte LDAP-Fragmente SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt +SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen +SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozenten gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen. +SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen +SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozenten daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen. +SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung +SchoolExamRequireModeForRegistrationTip: Sollen Dozenten gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen? +SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst SchoolTitle ssh@SchoolId: Institut „#{ssh}“ @@ -2314,6 +2376,11 @@ MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen. MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"} +MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen +MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen: +MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen: +MailAllocationNewCourseApplyHere: Sie können sich hier bewerben: + ExamOfficeSubscribedUsers: Benutzer ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren @@ -2788,4 +2855,7 @@ CronMatchAsap: ASAP CronMatchNone: Nie SystemExamOffice: Prüfungsverwaltung -SystemFaculty: Fakultätsmitglied \ No newline at end of file +SystemFaculty: Fakultätsmitglied + +ChangelogItemFeature: Feature +ChangelogItemBugfix: Bugfix \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 01e686a3e..be4d6958c 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -808,6 +808,15 @@ FormBehaviour: Behaviour FormCosmetics: Interface FormPersonalAppearance: Public data FormFieldRequiredTip: Required fields +FormAllocationNotifications: Notifications for new central allocation courses +FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications” + +AllocNotifyNewCourseDefault: System wide setting +AllocNotifyNewCourseForceOff: No +AllocNotifyNewCourseForceOn: Yes + +BtnNotifyNewCourseForceOn: Notify me +BtnNotifyNewCourseForceOff: Do not notify me PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented. PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented. @@ -1155,6 +1164,8 @@ NotificationTriggerCourseRegistered: A course administrator has enrolled me in a NotificationTriggerSubmissionUserCreated: I was added to an exercise sheet submission NotificationTriggerSubmissionEdited: One of my exercise sheet submissions was changed NotificationTriggerSubmissionUserDeleted: I was removed from one of my exercise sheet submissions +NotificationTriggerAllocationNewCourse: A new course was added to a central allocation for which I have registered my participation +NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation NotificationTriggerKindAll: For all users NotificationTriggerKindCourseParticipant: For course participants @@ -1851,6 +1862,39 @@ ExamFormOccurrences: Occurrences/rooms ExamFormAutomaticFunctions: Automatic functions ExamFormCorrection: Correction ExamFormParts: Exam parts +ExamFormMode: Exam design + +ExamModeFormNone: Not specified +ExamModeFormCustom: Custom +ExamModeFormAids: Permitted exam aids +ExamModeFormOnline: Online/Offline +ExamModeFormSynchronicity: Synchronous/Asynchronous +ExamModeFormRequiredEquipment: Required equipment +ExamModeFormRequiredEquipmentIdentificationTip: There will always be a note informing participants that they will need photo identification. + +ExamShowAids: Permitted exam aids +ExamShowOnline: Online/Offline +ExamShowSynchronicity: Synchronous/Asynchronous +ExamShowRequiredEquipment: Required equipment +ExamShowRequiredEquipmentNoneSet: Not specified +ExamShowIdentificationRequired: Exam participants need to be able to identify themselves. Therefor please ensure that you have official photo identification („Personalausweis“, passport, residence permit) and your student identification at hand during the exam. + +ExamOpenBook: Open book +ExamClosedBook: Closed book + +ExamOnline: Online +ExamOffline: Offline + +ExamSynchronous: Synchronous +ExamAsynchronous: Asynchronous + +ExamRequiredEquipmentNone: Nothing +ExamRequiredEquipmentPen: Pen +ExamRequiredEquipmentPaperPen: Pen & paper +ExamRequiredEquipmentCalculatorPen: Pen & calculator +ExamRequiredEquipmentCalculatorPaperPen: Pen, paper & calculator +ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & microphone +ExamRequiredEquipmentMicrophoneInternet: Microphone ExamCorrectors: Correctors ExamCorrectorsTip: Correctors configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants. @@ -1903,6 +1947,10 @@ ExamFinishedMustBeAfterStart: "Results visible from" must be after "start" ExamClosedMustBeAfterFinished: "Exam achievements registered" must be after "results visible from" ExamClosedMustBeAfterStart: "Exam achievements registered" must be after "start" ExamClosedMustBeAfterEnd: "Exam achievements registered" must be after "end" +ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Start". +ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to". +ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set. +ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start @@ -2222,6 +2270,13 @@ ApplicationRatingCommentVisibleTip: Feedback for the applicant ApplicationRatingCommentInvisibleTip: Currently only a note for course administrators ApplicationRatingSection: Grading ApplicationRatingSectionSelfTip: You are authorised to edit the application as well as it's grading. +AllocationNotificationNewCourse: Notifications for new courses +AllocationNotificationNewCourseTip: Do you want to be notified if a new course is added to this central allocation? This overrides the system wide setting under “Settings”. +AllocationNotificationNewCourseSuccessForceOn: You will be notified if a new course is added +AllocationNotificationNewCourseSuccessForceOff: You will not be notified if a new course is added +AllocationNotificationNewCourseCurrentlyOff: Currently you would not receive a notification. +AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified. +AllocationNotificationLoginFirst: To change your notification settings, please log in first. AllocationSchoolShort: Department Allocation: Central allocation @@ -2253,6 +2308,13 @@ SchoolName: Name SchoolLdapOrganisations: Associated LDAP fragments SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry SchoolLdapOrganisationMissing: LDAP-fragment is required +SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams +SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time. +SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams +SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days. +SchoolExamRequireModeForRegistration: Exam design required for registration +SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period? +SchoolExamDiscouragedModes: Exam designs to warn against SchoolUpdated ssh: Successfully edited #{ssh} SchoolTitle ssh: Department „#{ssh}“ @@ -2314,6 +2376,11 @@ MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated. MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"} +MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}” +MailAllocationNewCourseTip: The following course was added to the central allocation: +MailAllocationNewCourseEditApplicationsHere: You can modify your application here: +MailAllocationNewCourseApplyHere: You can apply here: + ExamOfficeSubscribedUsers: Users ExamOfficeSubscribedUsersTip: You may specify multiple matriculations; comma-separated @@ -2790,3 +2857,6 @@ CronMatchNone: Never SystemExamOffice: Exam office SystemFaculty: Faculty member + +ChangelogItemFeature: Feature +ChangelogItemBugfix: Bugfix \ No newline at end of file diff --git a/models/allocations.model b/models/allocations.model index 64f395a4d..f063a50ea 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -50,3 +50,9 @@ AllocationDeregister -- self-inflicted user-deregistrations from an allocated co course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) + +AllocationNotificationSetting + user UserId + allocation AllocationId + isOptOut Bool + UniqueAllocationNotificationSetting user allocation \ No newline at end of file diff --git a/models/changelog.model b/models/changelog.model new file mode 100644 index 000000000..4cc42cb12 --- /dev/null +++ b/models/changelog.model @@ -0,0 +1,4 @@ +ChangelogItemFirstSeen + item ChangelogItem + firstSeen Day + Primary item diff --git a/models/exams.model b/models/exams.model index bc51b17bb..497ea575c 100644 --- a/models/exams.model +++ b/models/exams.model @@ -17,6 +17,7 @@ Exam publicStatistics Bool gradingMode ExamGradingMode description Html Maybe + examMode ExamMode UniqueExam course name ExamPart exam ExamId diff --git a/models/schools.model b/models/schools.model index c5bd3d6ac..950b1c624 100644 --- a/models/schools.model +++ b/models/schools.model @@ -3,6 +3,10 @@ School json name (CI Text) shorthand (CI Text) -- SchoolKey :: SchoolShorthand -> SchoolId + examMinimumRegisterBeforeStart NominalDiffTime Maybe + examMinimumRegisterDuration NominalDiffTime Maybe + examRequireModeForRegistration Bool default=false + examDiscouragedModes ExamModeDNF UniqueSchool name UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } diff --git a/models/study-features.model b/models/study-features.model new file mode 100644 index 000000000..71b72ad0f --- /dev/null +++ b/models/study-features.model @@ -0,0 +1,58 @@ +StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login + user UserId + degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. + field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. + superField StudyTermsId Maybe + type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach + semester Int + firstObserved UTCTime Maybe + lastObserved UTCTime default=now() -- last update from LDAP + valid Bool default=true + relevanceCached Bool default=false + UniqueStudyFeatures user degree field type semester + deriving Eq Show + -- UniqueUserSubject ubuser degree field -- There exists a counterexample + +RelevantStudyFeatures + term TermId + studyFeatures StudyFeaturesId + UniqueRelevantStudyFeatures term studyFeatures + +StudyDegree -- Studienabschluss + key Int -- LMU-internal key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + Primary key -- column key is used as actual DB row key + -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } + deriving Eq Show +StudyTerms -- Studiengang + key Int -- standardised key + shorthand Text Maybe -- admin determined shorthand + name Text Maybe -- description given by LDAP + defaultDegree StudyDegreeId Maybe + defaultType StudyFieldType Maybe + Primary key -- column key is used as actual DB row key + -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } + deriving Eq Ord Show +StudySubTerms + child StudyTermsId + parent StudyTermsId + UniqueStudySubTerms child parent +StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. + -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. + -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. + -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations + incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs + key Int -- a possible key for the studyTermName or studySubTermName + name Text -- studyTermName as plain text from LDAP + deriving Show Eq Ord +StudySubTermParentCandidate + incidence TermCandidateIncidence + key Int + parent Int + deriving Show Eq Ord +StudyTermStandaloneCandidate + incidence TermCandidateIncidence + key Int + deriving Show Eq Ord + diff --git a/models/users.model b/models/users.model index b3b92e2d3..a8eb73c12 100644 --- a/models/users.model +++ b/models/users.model @@ -38,6 +38,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create UniqueAuthentication ident -- Column 'ident' can be used as a row-key in this table UniqueEmail email -- Column 'email' can be used as a row-key in this table deriving Show Eq Ord Generic -- Haskell-specific settings for runtime-value representing a row in memory + UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...) user UserId school SchoolId @@ -58,56 +59,6 @@ UserSchool -- Managed by users themselves, encodes "schools of interest" school SchoolId isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically UniqueUserSchool user school -StudyFeatures -- multiple entries possible for students pursuing several degrees at once, usually created upon LDAP login - user UserId - degree StudyDegreeId -- Abschluss, i.e. Master, Bachelor, etc. - field StudyTermsId -- Fach, i.e. Informatics, Philosophy, etc. - superField StudyTermsId Maybe - type StudyFieldType -- Major or minor, i.e. Haupt-/Nebenfach - semester Int - firstObserved UTCTime Maybe - lastObserved UTCTime default=now() -- last update from LDAP - valid Bool default=true - UniqueStudyFeatures user degree field type semester - deriving Eq Show - -- UniqueUserSubject ubuser degree field -- There exists a counterexample -StudyDegree -- Studienabschluss - key Int -- LMU-internal key - shorthand Text Maybe -- admin determined shorthand - name Text Maybe -- description given by LDAP - Primary key -- column key is used as actual DB row key - -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } - deriving Eq Show -StudyTerms -- Studiengang - key Int -- standardised key - shorthand Text Maybe -- admin determined shorthand - name Text Maybe -- description given by LDAP - defaultDegree StudyDegreeId Maybe - defaultType StudyFieldType Maybe - Primary key -- column key is used as actual DB row key - -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } - deriving Eq Ord Show -StudySubTerms - child StudyTermsId - parent StudyTermsId - UniqueStudySubTerms child parent -StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. - -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. - -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. - -- If a login provides n keys and n plan texts, then n^2 rows with the same incidence are created, storing all combinations - incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs - key Int -- a possible key for the studyTermName or studySubTermName - name Text -- studyTermName as plain text from LDAP - deriving Show Eq Ord -StudySubTermParentCandidate - incidence TermCandidateIncidence - key Int - parent Int - deriving Show Eq Ord -StudyTermStandaloneCandidate - incidence TermCandidateIncidence - key Int - deriving Show Eq Ord UserGroupMember group UserGroupName diff --git a/package-lock.json b/package-lock.json index 5a78f8bad..c2a023d6e 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.0", + "version": "20.6.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 92a1f56d5..57c4e377e 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "20.1.0", + "version": "20.6.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index fe4f0c6ce..6c59a87a6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 20.1.0 +version: 20.6.0 dependencies: - base @@ -25,7 +25,7 @@ dependencies: - directory - warp - data-default - - aeson + - aeson >=1.5 - conduit - monad-logger - fast-logger @@ -158,6 +158,7 @@ other-extensions: - IncoherentInstances - OverloadedLists - UndecidableInstances + - ApplicativeDo default-extensions: - OverloadedStrings diff --git a/routes b/routes index d0c137c64..8819dc282 100644 --- a/routes +++ b/routes @@ -109,7 +109,7 @@ /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: - / AShowR GET !free + / AShowR GET POST !free /register ARegisterR POST !time /course/#CryptoUUIDCourse/apply AApplyR POST !timeANDallocation-registered /users AUsersR GET POST !allocation-admin diff --git a/shell.nix b/shell.nix index 33411fdad..a6096242b 100644 --- a/shell.nix +++ b/shell.nix @@ -45,7 +45,7 @@ let pgSockDir=$(mktemp -d) pgLogFile=$(mktemp) initdb --no-locale -D ''${pgDir} - pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990" + pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700 -c max_connections=9990 -c shared_preload_libraries=pg_stat_statements -c auto_explain.log_min_duration=100ms" export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile} psql -f ${postgresSchema} postgres printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir} diff --git a/src/Control/Monad/Catch/Instances.hs b/src/Control/Monad/Catch/Instances.hs new file mode 100644 index 000000000..c0d1c3345 --- /dev/null +++ b/src/Control/Monad/Catch/Instances.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Control.Monad.Catch.Instances + () where + +import ClassyPrelude +import Control.Monad.Catch + + +deriving instance Functor ExitCase diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs index 15c77e94b..87e74ad1c 100644 --- a/src/Data/Time/Calendar/Instances.hs +++ b/src/Data/Time/Calendar/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Time.Calendar.Instances @@ -11,8 +10,13 @@ import Data.Time.Calendar import Data.Universe +import Language.Haskell.TH.Syntax (Lift) +import Type.Reflection -deriving newtype instance Hashable Day + +deriving instance Lift Day +instance Hashable Day where + hashWithSalt s (ModifiedJulianDay jDay) = s `hashWithSalt` hash (typeRep @Day) `hashWithSalt` jDay deriving instance Ord DayOfWeek instance Universe DayOfWeek where diff --git a/src/Data/Universe/Instances/Reverse/WithIndex.hs b/src/Data/Universe/Instances/Reverse/WithIndex.hs index ff6550058..66e6206cd 100644 --- a/src/Data/Universe/Instances/Reverse/WithIndex.hs +++ b/src/Data/Universe/Instances/Reverse/WithIndex.hs @@ -11,7 +11,7 @@ import Control.Lens.Indexed import Data.Universe.Instances.Reverse () -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map instance Finite a => FoldableWithIndex a ((->) a) where diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs index 03250be58..7ebc86ea7 100644 --- a/src/Data/Universe/TH.hs +++ b/src/Data/Universe/TH.hs @@ -14,7 +14,10 @@ import Data.Universe.Helpers (interleave) import Control.Monad (unless) -import Data.List (elemIndex) +import Data.List (elemIndex, nub) + +import Control.Lens hiding (universe) +import Data.Generics.Product.Types -- | Get type var bind name @@ -52,26 +55,37 @@ finiteEnum tName = do |] deriveUniverse, deriveFinite :: Name -> DecsQ -deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|] -deriveFinite tName = fmap concat . sequence $ - [ deriveUniverse' [e|concat|] [e|universeF|] tName - , do - DatatypeInfo{..} <- reifyDatatype tName - [d|instance Finite $(foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars)|] - ] +deriveUniverse tName = view _1 <$> deriveUniverse' [e|interleave|] [e|universe|] ([t|Universe|] `appT`) tName +deriveFinite tName = do + (decs, iCxt) <- deriveUniverse' [e|concat|] [e|universeF|] ([t|Finite|] `appT`) tName + fmap concat . sequence $ + [ pure decs + , do + DatatypeInfo{..} <- reifyDatatype tName + pure <$> instanceD (pure iCxt) (appT [t|Finite|] . foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars) [] + ] -deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ -deriveUniverse' interleaveExp universeExp tName = do +deriveUniverse' :: ExpQ -> ExpQ -> (TypeQ -> TypeQ) -> Name -> Q ([Dec], Cxt) +deriveUniverse' interleaveExp universeExp mkCxt tName = do DatatypeInfo{..} <- reifyDatatype tName - let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars - consUniverse ConstructorInfo{..} = do + let consUniverse ConstructorInfo{..} = do unless (null constructorVars) $ fail "Constructors with variables no supported" foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields - pure <$> instanceD (cxt []) [t|Universe $(datatype)|] + typ = foldl (\t bndr -> t `appT` varT (getTVBName bndr)) (conT tName) datatypeVars + iCxt = map (mkCxt . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes + where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map getTVBName datatypeVars + usesVar ConstructorInfo{..} n + | n `elem` map getTVBName constructorVars = False + | otherwise = any (elemOf types n) constructorFields + fieldTypes = nub $ concatMap constructorFields datatypeCons + + iCxt' <- cxt iCxt + + (, iCxt') . pure <$> instanceD (pure iCxt') [t|Universe $(typ)|] [ funD 'universe [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) [] ] diff --git a/src/Data/Void/Instances.hs b/src/Data/Void/Instances.hs index a59e0cd39..fc0abbb22 100644 --- a/src/Data/Void/Instances.hs +++ b/src/Data/Void/Instances.hs @@ -10,3 +10,6 @@ instance ToContent Void where toContent = absurd instance ToTypedContent Void where toTypedContent = absurd + +instance RenderMessage site Void where + renderMessage _ _ = absurd diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 71543f2d9..1d5ac1248 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -47,10 +47,6 @@ import Data.Text.Lens (packed) import Data.List ((!!)) -appLanguages :: NonEmpty Lang -appLanguages = "de-de-formal" :| ["en-eu"] - - pluralDE :: (Eq a, Num a) => a -- ^ Count -> Text -- ^ Singular @@ -225,6 +221,11 @@ embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) embedRenderMessage ''UniWorX ''FavouriteReason id embedRenderMessage ''UniWorX ''Sex id embedRenderMessage ''UniWorX ''ExamGradingMode id +embedRenderMessage ''UniWorX ''ExamAidsPreset id +embedRenderMessage ''UniWorX ''ExamOnlinePreset id +embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id +embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id +embedRenderMessage ''UniWorX ''ChangelogItemKind id embedRenderMessage ''UniWorX ''AuthenticationMode id diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 765c1b70f..8ca6c3b29 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -446,7 +446,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError) guard $ userSystemMessageShown <= Just systemMessageLastChanged guard $ userSystemMessageHidden <= Just systemMessageLastUnhide - (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId + (_, smTrans) <- MaybeT $ getSystemMessage smId let (summary, content) = case smTrans of Nothing -> (systemMessageSummary, systemMessageContent) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 1c8bd1e61..321f80691 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -343,7 +343,19 @@ upsertCampusUser upsertMode ldapData = do , Just defType <- studyTermsDefaultType -> do $logDebugS "Campus" [st|Applying default for standalone study term “#{tshow subterm}”|] - (:) (StudyFeatures userId defDegree subterm Nothing defType subSemester (Just now) now True) <$> assimilateSubTerms subterms unusedFeats + let sf = StudyFeatures + { studyFeaturesUser = userId + , studyFeaturesDegree = defDegree + , studyFeaturesField = subterm + , studyFeaturesSuperField = Nothing + , studyFeaturesType = defType + , studyFeaturesSemester = subSemester + , studyFeaturesFirstObserved = Just now + , studyFeaturesLastObserved = now + , studyFeaturesValid = True + , studyFeaturesRelevanceCached = False + } + (sf :) <$> assimilateSubTerms subterms unusedFeats Nothing | [] <- unusedFeats -> do $logDebugS "Campus" [st|Saw subterm “#{tshow subterm}” when no fos-terms remain|] @@ -418,6 +430,8 @@ upsertCampusUser upsertMode ldapData = do ] associateUserSchoolsByTerms userId + cacheStudyFeatureRelevance $ \studyFeatures -> studyFeatures E.^. StudyFeaturesUser E.==. E.val userId + let userAssociatedSchools = concat <$> forM userAssociatedSchools' parseLdapSchools userAssociatedSchools' = do diff --git a/src/Foundation/Yesod/Middleware.hs b/src/Foundation/Yesod/Middleware.hs index 6ba2b61ca..1a7183602 100644 --- a/src/Foundation/Yesod/Middleware.hs +++ b/src/Foundation/Yesod/Middleware.hs @@ -7,7 +7,6 @@ import Import.NoFoundation hiding (yesodMiddleware) import Foundation.Type import Foundation.Routes -import Foundation.I18n import Foundation.Authorization import Utils.Metrics diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index f48db411e..7996f3af3 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -19,10 +19,11 @@ import qualified Database.Esqueleto as E import qualified Data.Conduit.List as C -data AllocationApplicationButton = BtnAllocationApply - | BtnAllocationApplicationEdit - | BtnAllocationApplicationRetract - | BtnAllocationApplicationRate +data AllocationApplicationButton + = BtnAllocationApply + | BtnAllocationApplicationEdit + | BtnAllocationApplicationRetract + | BtnAllocationApplicationRate deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe AllocationApplicationButton instance Finite AllocationApplicationButton @@ -32,6 +33,11 @@ embedRenderMessage ''UniWorX ''AllocationApplicationButton id makePrisms ''AllocationApplicationButton instance Button UniWorX AllocationApplicationButton where + btnLabel BtnAllocationApply = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|] + btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|] + btnLabel BtnAllocationApplicationEdit = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|] + btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate + btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger] btnClasses _ = [BCIsButton, BCPrimary] diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index 9629335c7..3a6a4eb0c 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -36,6 +36,19 @@ nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1 embedRenderMessage ''UniWorX ''AllocationRegisterButton id instance Button UniWorX AllocationRegisterButton where + btnLabel BtnAllocationRegister + = [whamlet| + $newline never + #{iconAllocationRegister} \ + _{BtnAllocationRegister} + |] + btnLabel BtnAllocationRegistrationEdit + = [whamlet| + $newline never + #{iconAllocationRegistrationEdit} \ + _{BtnAllocationRegistrationEdit} + |] + btnClasses _ = [BCIsButton, BCPrimary] postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 1df2e5506..1280a4a64 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -1,5 +1,5 @@ module Handler.Allocation.Show - ( getAShowR + ( getAShowR, postAShowR ) where import Import @@ -7,6 +7,7 @@ import Import import Utils.Course import Handler.Utils +import Handler.Utils.Allocation (allocationNotifyNewCourses) import Handler.Allocation.Register import Handler.Allocation.Application @@ -15,8 +16,34 @@ import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E -getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html -getAShowR tid ssh ash = do +data NotifyNewCourseButton + = BtnNotifyNewCourseForceOn + | BtnNotifyNewCourseForceOff + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''NotifyNewCourseButton id +nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2 + +instance Button UniWorX NotifyNewCourseButton where + btnLabel BtnNotifyNewCourseForceOn + = [whamlet| + $newline never + #{iconNotification} \ + _{BtnNotifyNewCourseForceOn} + |] + btnLabel BtnNotifyNewCourseForceOff + = [whamlet| + $newline never + #{iconNoNotification} \ + _{BtnNotifyNewCourseForceOff} + |] + + btnClasses _ = [BCIsButton] + + +getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html +getAShowR = postAShowR +postAShowR tid ssh ash = do muid <- maybeAuthId now <- liftIO getCurrentTime ata <- getSessionActiveAuthTags @@ -33,7 +60,7 @@ getAShowR tid ssh ash = do resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool resultCourseVisible = _5 . _Value - (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do + (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration, wouldNotifyNewCourse) <- runDB $ do alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash school <- getJust allocationSchool @@ -58,7 +85,9 @@ getAShowR tid ssh ash = do isAnyLecturer <- hasWriteAccessTo CourseNewR - return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration) + wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val + + return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse) MsgRenderer mr <- getMsgRenderer let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName @@ -67,7 +96,7 @@ getAShowR tid ssh ash = do -- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) -> -- hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR - (registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration + (registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration let registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration registerForm' = wrapForm' registerBtn registerForm FormSettings @@ -79,6 +108,35 @@ getAShowR tid ssh ash = do , formAnchor = Nothing :: Maybe Text } + ((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if + | wouldNotifyNewCourse + -> [BtnNotifyNewCourseForceOff] + | otherwise + -> [BtnNotifyNewCourseForceOn] + let + allocationNotificationIdent = "allocation-notification" :: Text + notificationForm' = wrapForm notificationForm FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR + , formEncoding = notificationEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Just allocationNotificationIdent + } + + whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do + let allocationNotificationSettingIsOptOut = case notificationBtn of + BtnNotifyNewCourseForceOn -> False + BtnNotifyNewCourseForceOff -> True + runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting + { allocationNotificationSettingUser = uid + , allocationNotificationSettingAllocation = aId + , allocationNotificationSettingIsOptOut + } + [ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ] + addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut + redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent + siteLayoutMsg title $ do setTitleI shortTitle diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 09e032bbb..ab1548823 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -243,6 +243,15 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB allocationOptions <- mkOptionList <$> mapM mkAllocationOption (availableAllocations ++ activeAllocations) let + explainedAllocationOptions = return allocationOptions `explainOptionList` \allocId -> hoistMaybe . listToMaybe $ do + (Entity allocId' Allocation{..}, _) <- availableAllocations' + guard $ allocId' == allocId + toWidget <$> hoistMaybe allocationStaffDescription + + doExplain = has (folded . _entityVal . _allocationStaffDescription . _Just) $ availableAllocations ++ activeAllocations + allocField | doExplain = explainedSelectionField Nothing explainedAllocationOptions + | otherwise = selectField' Nothing $ return allocationOptions + userAdmin = not $ null adminSchools mayChange = Just False /= fmap (|| userAdmin) currentAllocationAvailable @@ -254,7 +263,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB | otherwise = aforcedJust in AllocationCourseForm - <$> ainp (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) + <$> ainp allocField (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation) <*> ainp (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation) <*> apopt checkBoxField (fslI MsgCourseDeregisterNoShow & setTooltip MsgCourseDeregisterNoShowTip) ((<|> Just True) . fmap acfDeregisterNoShow $ template >>= cfAllocation) @@ -554,18 +563,18 @@ courseEditHandler miButtonAction mbCourseForm = do , formEncoding = formEnctype } -upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m () +upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX () upsertAllocationCourse cid cfAllocation = do now <- liftIO getCurrentTime Course{} <- getJust cid prevAllocationCourse <- getBy $ UniqueAllocationCourse cid - prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse - userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) + prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse + userAdmin <- fromMaybe False <$> for prevAllocation (\(Entity _ Allocation{..}) -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR) doEdit <- if | userAdmin -> return True - | Just Allocation{allocationStaffRegisterTo} <- prevAllocation + | Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation , NTop allocationStaffRegisterTo <= NTop (Just now) -> let anyChanges | Just AllocationCourseForm{..} <- cfAllocation @@ -581,7 +590,7 @@ upsertAllocationCourse cid cfAllocation = do when doEdit $ case cfAllocation of - Just AllocationCourseForm{..} -> + Just AllocationCourseForm{..} -> do void $ upsert AllocationCourse { allocationCourseAllocation = acfAllocation , allocationCourseCourse = cid @@ -591,6 +600,9 @@ upsertAllocationCourse cid cfAllocation = do , AllocationCourseCourse =. cid , AllocationCourseMinCapacity =. acfMinCapacity ] + + when (Just acfAllocation /= fmap entityKey prevAllocation) $ + queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid Nothing | Just (Entity prevId _) <- prevAllocationCourse -> delete prevId diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index e284edc76..16fcc6357 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -25,7 +25,7 @@ postEEditR tid ssh csh examn = do return (cid, exam, template) - ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template formResult editExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do @@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do , examPublicStatistics = efPublicStatistics , examGradingMode = efGradingMode , examDescription = efDescription + , examExamMode = efExamMode } when (is _Nothing insertRes) $ do diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1bfa7f79a..666b5af2e 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -12,12 +12,14 @@ import Handler.Exam.CorrectorInvite () import Handler.Utils import Handler.Utils.Invitations +import Handler.Utils.Exam (evalExamModeDNF) import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Control.Monad.State.Class as State import Text.Blaze.Html.Renderer.String (renderHtml) @@ -40,6 +42,7 @@ data ExamForm = ExamForm , efGradingRule :: Maybe ExamGradingRule , efBonusRule :: Maybe ExamBonusRule , efOccurrenceRule :: ExamOccurrenceRule + , efExamMode :: ExamMode , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } @@ -52,7 +55,18 @@ data ExamOccurrenceForm = ExamOccurrenceForm , eofStart :: UTCTime , eofEnd :: Maybe UTCTime , eofDescription :: Maybe Html - } deriving (Read, Show, Eq, Ord, Generic, Typeable) + } deriving (Read, Show, Eq, Generic, Typeable) + +instance Ord ExamOccurrenceForm where + compare = mconcat + [ comparing eofName + , comparing eofStart + , comparing eofRoom + , comparing eofEnd + , comparing eofCapacity + , comparing eofDescription + , comparing eofId + ] data ExamPartForm = ExamPartForm { epfId :: Maybe CryptoUUIDExamPart @@ -60,7 +74,16 @@ data ExamPartForm = ExamPartForm , epfName :: Maybe ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational - } deriving (Read, Show, Eq, Ord, Generic, Typeable) + } deriving (Read, Show, Eq, Generic, Typeable) + +instance Ord ExamPartForm where + compare = mconcat + [ comparing epfNumber + , comparing epfName + , comparing epfMaxPoints + , comparing epfWeight + , comparing epfId + ] makeLenses_ ''ExamForm @@ -97,6 +120,8 @@ examForm template html = do <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template) <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template) <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <* aformSection MsgExamFormMode + <*> examModeForm (efExamMode <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts @@ -282,6 +307,7 @@ examFormTemplate (Entity eId Exam{..}) = do Entity _ ExamCorrector{..} <- correctors return examCorrectorUser ] + , efExamMode = examExamMode } examTemplate :: CourseId -> DB (Maybe ExamForm) @@ -327,11 +353,12 @@ examTemplate cid = runMaybeT $ do , efOccurrences = Set.empty , efExamParts = Set.empty , efCorrectors = Set.empty + , efExamMode = examExamMode oldExam } -validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () -validateExam = do +validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m () +validateExam cId oldExam = do ExamForm{..} <- State.get guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom @@ -357,3 +384,50 @@ validateExam = do ] guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b + + mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do + E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId + E.where_ $ course E.^. CourseId E.==. E.val cId + return school + + whenIsJust mSchool $ \(Entity _ School{..}) -> do + whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do + let doValidation + | Just Exam{..} <- oldExam + , not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom) + = warnValidation + | otherwise + = guardValidation + doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay) + . fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom) + whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do + let doValidation + | Just Exam{..} <- oldExam + , not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom) + = warnValidation + | otherwise + = guardValidation + doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay) + . fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom) + when schoolExamRequireModeForRegistration $ do + let doValidation + | Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam + , or [ is _Nothing examAids + , is _Nothing examOnline + , is _Nothing examSynchronicity + , is _Nothing examRequiredEquipment + ] + , is _Just examRegisterFrom + = warnValidation + | otherwise + = guardValidation + let ExamMode{..} = efExamMode + doValidation MsgExamModeRequiredForRegistration + $ is _Nothing efRegisterFrom + || and [ is _Just examAids + , is _Just examOnline + , is _Just examSynchronicity + , is _Just examRequiredEquipment + ] + + warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index ebc1fcde8..7b04df98a 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -24,7 +24,7 @@ postCExamNewR tid ssh csh = do template <- examTemplate cid return (cid, template) - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do @@ -49,6 +49,7 @@ postCExamNewR tid ssh csh = do , examGradingMode = efGradingMode , examPublicStatistics = efPublicStatistics , examDescription = efDescription + , examExamMode = efExamMode } whenIsJust insertRes $ \examid -> do insertMany_ diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index e206bc17b..b90bde092 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -26,8 +26,9 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do + (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn + school <- getJust examCourse >>= belongsToJust courseSchool let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -82,7 +83,7 @@ getEShowR tid ssh csh examn = do lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) + return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown @@ -174,6 +175,11 @@ getEShowR tid ssh csh examn = do let heading = prependCourseTitle tid ssh csh $ CI.original examName + notificationDiscouragedExamMode <- runMaybeT $ do + guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode + guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR + return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged + siteLayoutMsg heading $ do setTitleI heading let @@ -190,4 +196,6 @@ getEShowR tid ssh csh examn = do occurrenceMapping :: ExamOccurrenceName -> Maybe Widget occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping) + + notificationPersonalIdentification = notification NotificationBroad =<< messageIconI Info IconPersonalIdentification MsgExamShowIdentificationRequired $(widgetFile "exam-show") diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index f62a9db0e..c45c5c9d6 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -5,7 +5,9 @@ import Handler.Utils import Handler.Info.TH import qualified Data.Map as Map +import Data.Map ((!)) import qualified Data.CaseInsensitive as CI +import qualified Data.Set as Set import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E @@ -34,17 +36,26 @@ getLegalR = -- | Allgemeine Informationen getInfoR :: Handler Html -getInfoR = -- do +getInfoR = do + changelogEntries' <- runDB $ selectList [] [] + let changelogEntries = Map.fromListWith Set.union + [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem) + | Entity _ ChangelogItemFirstSeen{..} <- changelogEntries' + ] + siteLayoutMsg MsgInfoHeading $ do setTitleI MsgInfoHeading let features = $(i18nWidgetFile "featureList") - changeLog = $(i18nWidgetFile "changelog") + changeLog = $(widgetFile "changelog") knownBugs = $(i18nWidgetFile "knownBugs") implementation = $(i18nWidgetFile "implementation") gitInfo :: Text gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" $(widgetFile "versionHistory") + where + changelogItems = $(i18nWidgetFiles "changelog") + getInfoLecturerR :: Handler Html getInfoLecturerR = @@ -67,9 +78,9 @@ getInfoLecturerR = -- new feature with given introduction date newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX () - newFeat year month day = do + newFeat y m d = do currentTime <- liftIO getCurrentTime - let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0 + let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0 if currentTime > expiryTime then mempty else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |] @@ -90,7 +101,7 @@ getGlossaryR = msgMap = $(glossaryTerms "glossary") -mkFaqItems "faq" +mkI18nWidgetEnum "FAQ" "faq" mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal" faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX diff --git a/src/Handler/Info/TH.hs b/src/Handler/Info/TH.hs index a36694c5c..25c55bdb6 100644 --- a/src/Handler/Info/TH.hs +++ b/src/Handler/Info/TH.hs @@ -1,6 +1,5 @@ module Handler.Info.TH ( glossaryTerms - , mkFaqItems ) where import Import @@ -22,52 +21,3 @@ glossaryTerms basename = do where unPathPiece :: Text -> String unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-" - -mkFaqItems :: FilePath -> DecsQ -mkFaqItems basename = do - itemsAvailable <- i18nWidgetFilesAvailable' basename - let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable - sequence - [ dataD (cxt []) dataName [] Nothing - [ normalC (mkName conName) [] - | (_, conName) <- Map.toAscList items - ] - [ derivClause (Just StockStrategy) - [ conT ''Eq - , conT ''Ord - , conT ''Read - , conT ''Show - , conT ''Enum - , conT ''Bounded - , conT ''Generic - , conT ''Typeable - ] - , derivClause (Just AnyclassStrategy) - [ conT ''Universe - , conT ''Finite - ] - ] - , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName) - [ funD 'toPathPiece - [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) [] - | (int, con) <- Map.toList items - ] - , funD 'fromPathPiece - [ clause [varP $ mkName "t"] - ( guardedB - [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|] - | (int, con) <- Map.toList items - ]) [] - , clause [wildP] (normalB [e|Nothing|]) [] - ] - ] - , sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|] - , funD (mkName "faqItemMap") - [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) [] - ] - ] - where - unPathPiece :: Text -> String - unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-" - - dataName = mkName "FAQItem" diff --git a/src/Handler/Metrics.hs b/src/Handler/Metrics.hs index 0250e9851..cd1a6baa3 100644 --- a/src/Handler/Metrics.hs +++ b/src/Handler/Metrics.hs @@ -21,7 +21,8 @@ getMetricsR = selectRep $ do where metricsHtml :: Handler Html metricsHtml = do - samples <- collectMetrics + let metricSort = comparing $ \(SampleGroup Info{..} _ mSamples) -> (metricName, mSamples <&> \(Sample sampleName lbls _) -> (sampleName, lbls)) + samples <- sortBy metricSort <$> collectMetrics metricsBearer <- runMaybeT . hoist runDB $ do uid <- MaybeT maybeAuthId diff --git a/src/Handler/News.hs b/src/Handler/News.hs index 3b3c1997f..75b79009d 100644 --- a/src/Handler/News.hs +++ b/src/Handler/News.hs @@ -74,7 +74,7 @@ newsSystemMessages = do (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $ transPipe lift (selectKeys [] []) .| C.filterM (hasReadAccessTo . MessageR <=< encrypt) - .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId) + .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId) .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) .| C.mapMaybeM checkHidden .| C.iterM (\(smId, _, _, _) -> tellShown smId) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 04518240d..a71375fc1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -45,6 +45,7 @@ data SettingsForm = SettingsForm , stgShowSex :: Bool , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings + , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool) } makeLenses_ ''SettingsForm @@ -79,6 +80,15 @@ instance RenderMessage UniWorX NotificationTriggerKind where where mr = renderMessage f ls +data AllocationNotificationState + = AllocNotifyNewCourseDefault + | AllocNotifyNewCourseForceOff + | AllocNotifyNewCourseForceOn + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +embedRenderMessage ''UniWorX ''AllocationNotificationState id +nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2 + makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do @@ -108,6 +118,7 @@ makeSettingForm template html = do <* aformSection MsgFormNotifications <*> schoolsForm (stgSchools <$> template) <*> notificationForm (stgNotificationSettings <$> template) + <*> allocationNotificationForm (stgAllocationNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF] @@ -196,13 +207,17 @@ notificationForm template = wFormToAForm $ do & fmap (!) let + ntfs nt = fslI nt & case nt of + NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip + _other -> id + nsForm nt | maybe False ntHidden $ ntSection nt = pure $ notificationAllowed def nt | nt `elem` forcedTriggers - = aforced checkBoxField (fslI nt) (notificationAllowed def nt) + = aforced checkBoxField (ntfs nt) (notificationAllowed def nt) | otherwise - = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template) + = apopt checkBoxField (ntfs nt) (flip notificationAllowed nt <$> template) ntSection = \case NTSubmissionRatedGraded -> Just NTKCourseParticipant @@ -229,6 +244,7 @@ notificationForm template = wFormToAForm $ do NTAllocationOutdatedRatings -> Just NTKAllocationStaff NTAllocationUnratedApplications -> Just NTKAllocationStaff NTAllocationResults -> Just NTKAllocationParticipant + NTAllocationNewCourse -> Just NTKAllocationParticipant NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice NTCourseRegistered -> Just NTKAll @@ -238,6 +254,62 @@ notificationForm template = wFormToAForm $ do aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False +getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool)) +getAllocationNotifications uid + = fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any))) + [ getBySettings + , getByApplications + , getByAllocationUser + ] + where + getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] [] + where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation + , Just $ not allocationNotificationSettingIsOptOut + ) + | Entity _ AllocationNotificationSetting{..} <- settings + ] + getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] [] + where toMap applications = Map.fromList [ (alloc, Nothing) + | Entity _ CourseApplication{..} <- applications + , alloc <- hoistMaybe courseApplicationAllocation + ] + getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] [] + where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing) + | Entity _ AllocationUser{..} <- allocsUser + ] + +setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m () +setAllocationNotifications allocationNotificationSettingUser allocs = do + deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ] + void . insertMany $ do + (allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs + allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt + return AllocationNotificationSetting{..} + +allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) +allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<) + where + allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool)) + allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do + let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState + _AllocNotify = iso toNotify fromNotify + where fromNotify = \case + AllocNotifyNewCourseDefault -> Nothing + AllocNotifyNewCourseForceOn -> Just True + AllocNotifyNewCourseForceOff -> Just False + toNotify = \case + Nothing -> AllocNotifyNewCourseDefault + Just True -> AllocNotifyNewCourseForceOn + Just False -> AllocNotifyNewCourseForceOff + + Allocation{..} <- liftHandler . runDB $ getJust allocId + MsgRenderer mr <- getMsgRenderer + let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|] + cID <- encrypt allocId :: _ CryptoUUIDAllocation + + fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify) + where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False + validateSettings :: User -> FormValidator SettingsForm Handler () validateSettings User{..} = do @@ -276,6 +348,7 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId + allocs <- runDB $ getAllocationNotifications uid let settingsTemplate = Just SettingsForm { stgDisplayName = userDisplayName , stgDisplayEmail = userDisplayEmail @@ -290,6 +363,7 @@ postProfileR = do , stgNotificationSettings = userNotificationSettings , stgWarningDays = userWarningDays , stgShowSex = userShowSex + , stgAllocationNotificationSettings = allocs } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate @@ -308,6 +382,7 @@ postProfileR = do , UserNotificationSettings =. stgNotificationSettings , UserShowSex =. stgShowSex ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] + setAllocationNotifications uid stgAllocationNotificationSettings updateFavourites Nothing when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail @@ -777,9 +852,13 @@ getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html getUserNotificationR = postUserNotificationR postUserNotificationR cID = do uid <- decrypt cID - User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid + (User{userNotificationSettings, userDisplayName}, allocs) <- runDB $ (,) + <$> get404 uid + <*> getAllocationNotifications uid - ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings + ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,) + <$> notificationForm (Just userNotificationSettings) + <*> allocationNotificationForm (Just allocs) mBearer <- askBearer isModal <- hasCustomHeader HeaderIsModal let formWidget = wrapForm nsInnerWdgt def @@ -788,8 +867,10 @@ postUserNotificationR cID = do , formAttrs = [ asyncSubmitAttr | isModal ] } - formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do - lift . runDB $ update uid [ UserNotificationSettings =. ns ] + formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do + lift . runDB $ do + update uid [ UserNotificationSettings =. ns ] + setAllocationNotifications uid ans tell . pure =<< messageI Success MsgNotificationSettingsUpdate siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 4c72381bf..2ba5695e4 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -62,6 +62,10 @@ data SchoolForm = SchoolForm { sfShorthand :: CI Text , sfName :: CI Text , sfOrgUnits :: Set (CI Text) + , sfExamMinimumRegisterBeforeStart + , sfExamMinimumRegisterDuration :: Maybe NominalDiffTime + , sfExamRequireModeForRegistration :: Bool + , sfExamDiscouragedModes :: ExamModeDNF } mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm @@ -69,6 +73,10 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort) <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template) <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template)) + <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template) + <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template) + <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template) + <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)) where ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text)) ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ @@ -82,6 +90,10 @@ schoolToForm ssh = do { sfShorthand = schoolShorthand , sfName = schoolName , sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags + , sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart + , sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration + , sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration + , sfExamDiscouragedModes = schoolExamDiscouragedModes } @@ -94,7 +106,13 @@ postSchoolEditR ssh = do formResult sfResult $ \SchoolForm{..} -> do runDB $ do - update ssh [ SchoolName =. sfName ] + update ssh + [ SchoolName =. sfName + , SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart + , SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration + , SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration + , SchoolExamDiscouragedModes =. sfExamDiscouragedModes + ] forM_ sfOrgUnits $ \schoolLdapOrgUnit -> void $ upsert SchoolLdap { schoolLdapSchool = Just ssh @@ -131,6 +149,10 @@ postSchoolNewR = do didInsert <- is _Just <$> insertUnique School { schoolShorthand = sfShorthand , schoolName = sfName + , schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart + , schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration + , schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration + , schoolExamDiscouragedModes = sfExamDiscouragedModes } when didInsert $ do insert_ UserFunction diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 79ee42ae6..83d6aa46b 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -25,7 +25,7 @@ getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html getMessageR = postMessageR postMessageR cID = do smId <- decrypt cID - (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId + (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId let (summary, content) = case translation of Nothing -> (systemMessageSummary, systemMessageContent) Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent) @@ -185,7 +185,7 @@ postMessageListR = do in cell . toWidget $ fromMaybe content summary ] dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do - smT <- (>>= view _2) <$> getSystemMessage appLanguages smId + smT <- (>>= view _2) <$> getSystemMessage smId return DBRow { dbrOutput = (smE, smT) , .. diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index db512e25a..cefdf7c1a 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -1,5 +1,5 @@ module Handler.Utils.Allocation - ( allocationStarted + ( allocationStarted, allocationNotifyNewCourses , ordinalPriorities , sinkAllocationPriorities , MatchingLogRun(..) @@ -70,6 +70,25 @@ allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from E.where_ $ allocationMatching E.^. AllocationMatchingAllocation E.==. E.val allocId return . E.min_ $ allocationMatching E.^. AllocationMatchingTime +allocationNotifyNewCourses :: E.SqlExpr (E.Value AllocationId) + -> E.SqlExpr (E.Value UserId) + -> E.SqlExpr (E.Value Bool) +allocationNotifyNewCourses allocId uid = ( hasOverride True E.||. hasApplication E.||. isParticipant ) + E.&&. E.not_ (hasOverride False) + where + hasOverride overrideVal = E.exists . E.from $ \allocationNotificationSetting -> + E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. uid + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. allocId + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut E.==. E.val (not overrideVal) + + hasApplication = E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just allocId + E.&&. application E.^. CourseApplicationUser E.==. uid + + isParticipant = E.exists . E.from $ \allocationUser -> + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. allocId + E.&&. allocationUser E.^. AllocationUserUser E.==. uid + ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m () ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ) diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index a321bebff..63bf227ac 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -213,9 +213,9 @@ formatDiffDays t setYear :: Integer -> Day -> Day -setYear year date = fromGregorian year month day +setYear year date = fromGregorian year m d where - (_,month,day) = toGregorian date + (_,m,d) = toGregorian date addOneWeek :: UTCTime -> UTCTime addOneWeek = addWeeks 1 @@ -295,7 +295,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail formatGregorianW :: Integer -> Int -> Int -> Widget -formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day +formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d instance Csv.ToField ZonedTime where toField = Csv.toField . iso8601Show diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 54632cde6..1071cc435 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -11,6 +11,8 @@ module Handler.Utils.Exam , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize , examAutoOccurrence , deregisterExamUsersCount, deregisterExamUsers + , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget + , evalExamModeDNF ) where import Import @@ -50,6 +52,8 @@ import qualified Data.Char as Char import qualified Data.RFC5051 as RFC5051 +import Handler.Utils.I18n + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -641,3 +645,38 @@ deregisterExamUsersCount eId uids = do deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m () deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids + + +examAidsPresetWidget :: ExamAidsPreset -> Widget +examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids") + +examOnlinePresetWidget :: ExamOnlinePreset -> Widget +examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online") + +examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget +examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity") + +examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget +examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment") + + +evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool +evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} + = dnfTerms + & map (Set.toList . toNullable) . Set.toList + & map ( maybe True (ofoldr1 (&&)) + . fromNullable + . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl) + ) + & maybe False (ofoldr1 (||)) . fromNullable + where + evalPred :: ExamModePredicate -> Bool + evalPred = \case + ExamModePredAids p + -> examAids == Just (ExamAidsPreset p) + ExamModePredOnline p + -> examOnline == Just (ExamOnlinePreset p) + ExamModePredSynchronicity p + -> examSynchronicity == Just (ExamSynchronicityPreset p) + ExamModePredRequiredEquipment p + -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p) diff --git a/src/Handler/Utils/Files.hs b/src/Handler/Utils/Files.hs index aa0d280bc..8d8ca5dd8 100644 --- a/src/Handler/Utils/Files.hs +++ b/src/Handler/Utils/Files.hs @@ -40,9 +40,11 @@ sourceFileDB fileReference = do return $ E.substring (fileContentChunk E.^. FileContentChunkContent) (E.val start) (E.val dbChunksize) case chunk of Nothing -> throwM SourceFilesContentUnavailable - Just (E.Value c) -> return . Just . (c, ) $ if - | olength c >= dbChunksize -> Just $ start + dbChunksize - | otherwise -> Nothing + Just (E.Value c) -> do + observeSourcedChunk StorageDB $ olength c + return . Just . (c, ) $ if + | olength c >= dbChunksize -> Just $ start + dbChunksize + | otherwise -> Nothing chunkHashes = E.selectSource . E.from $ \fileContentEntry -> do E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryIx ] @@ -65,7 +67,10 @@ sourceFileMinio fileReference = do mChunk <- atomically $ Right <$> takeTMVar chunkVar <|> Left <$> waitCatchSTM minioAsync case mChunk of - Right chunk -> yield chunk >> go + Right chunk -> do + observeSourcedChunk StorageMinio $ olength chunk + yield chunk + go Left (Right ()) -> return () Left (Left exc) -> throwM exc in go diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 4be16133b..25053ed09 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -19,6 +19,8 @@ import Handler.Utils.I18n import Handler.Utils.Files +import Handler.Utils.Exam + import Import import Data.Char ( chr, ord, isDigit ) import qualified Data.Char as Char @@ -1327,35 +1329,28 @@ boolField mkNone = radioGroupField mkNone $ do -sectionedFuncForm :: forall k v m sec. - ( Finite k, Ord k +sectionedFuncForm :: forall f k v m sec. + ( TraversableWithIndex k f , MonadHandler m , HandlerSite m ~ UniWorX , RenderMessage UniWorX sec , Ord sec ) - => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) + => (k -> Maybe sec) -> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v) sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty where - funcForm' :: AForm m (k -> v) - funcForm' = Set.fromList universeF - & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty - & fmap (Map.fromSet mkForm) - & fmap sequenceA - & Map.foldrWithKey accSections (pure Map.empty) - & fmap (!) - accSections mSection optsForm acc = wFormToAForm $ do - (res, fs) <- wFormFields $ aFormToWForm optsForm - if - | not $ null fs - , Just section <- mSection - -> wformSection section - | otherwise - -> return () - lift $ tell fs - aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc + funcForm' :: AForm m (f v) + funcForm' = wFormToAForm $ do + (res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form + -> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form - funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX]) + iforM_ fs $ \mSection secfs -> unless (null secfs) $ do + traverse_ wformSection mSection + lift $ tell secfs + + return $ sequenceA res + + funcFieldView :: (FormResult (f v), Widget) -> MForm m (FormResult (f v), [FieldView UniWorX]) funcFieldView (res, formView) = do mr <- getMessageRender fvId <- maybe newIdent return fsId @@ -1367,16 +1362,15 @@ sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} is | otherwise = Nothing fvInput = $(widgetFile "widgets/fields/funcField") return (res, pure FieldView{..}) - -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template) -funcForm :: forall k v m. - ( Finite k, Ord k +funcForm :: forall f k v m. + ( TraversableWithIndex k f , MonadHandler m , HandlerSite m ~ UniWorX ) - => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) -funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text) + => f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v) +funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void) @@ -1944,3 +1938,97 @@ courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField ( userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User)) -> Handler (OptionList UserId) userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName + + +data CustomPresetFormOption p + = CPFONone + | CPFOPreset p + | CPFOCustom + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveFinite ''CustomPresetFormOption +derivePathPiece ''CustomPresetFormOption (camelToPathPiece' 1) "--" + +customPresetForm :: forall a custom preset msg. + ( Finite preset, Ord preset, PathPiece preset + , RenderMessage UniWorX msg + ) + => Iso' a (Either custom preset) + -> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option + -> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for custom option + -> (preset -> (msg, Maybe Widget)) + -> (Maybe custom -> AForm Handler custom) + -> FieldSettings UniWorX + -> Maybe (Maybe a) + -> AForm Handler (Maybe a) +customPresetForm cpL noneOption customOption toOption customForm fs mPrev + = explainedMultiActionA actionMap options fs $ Just mPrev' + where + mPrev' = case mPrev ^? _Just . _Just . cpL of + Nothing -> CPFONone + Just (Left _) -> CPFOCustom + Just (Right p) -> CPFOPreset p + + options = explainOptionList options' $ hoistMaybe . optionToWidget + where options' = do + MsgRenderer mr <- getMsgRenderer + let olReadExternal t = do + opt <- fromPathPiece t + case opt of + CPFONone -> opt <$ hoistMaybe noneOption + CPFOCustom -> opt <$ hoistMaybe customOption + CPFOPreset _ -> pure opt + olOptions = do + optionInternalValue <- universeF + optionDisplay <- case optionInternalValue of + CPFONone -> views _1 mr <$> hoistMaybe noneOption + CPFOCustom -> views _1 mr <$> hoistMaybe customOption + CPFOPreset p -> return . views _1 mr $ toOption p + let optionExternalValue = toPathPiece optionInternalValue + return Option{..} + return OptionList{..} + optionToWidget = \case + CPFONone -> noneOption ^? _Just . _2 . _Just + CPFOCustom -> customOption ^? _Just . _2 . _Just + CPFOPreset p -> toOption p ^. _2 + + actionMap :: Map (CustomPresetFormOption preset) (AForm Handler (Maybe a)) + actionMap = Map.fromList $ do + opt <- universeF + return . (opt, ) $ case opt of + CPFONone -> pure Nothing + CPFOPreset p -> pure . Just $ cpL # Right p + CPFOCustom -> reviews cpL Just . Left <$> customForm (mPrev ^? _Just . _Just . cpL . _Left) + +examModeForm :: Maybe ExamMode -> AForm Handler ExamMode +examModeForm mPrev = examMode + <$> customPresetForm examSynchronicityEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examSynchronicityPresetWidget) (apreq htmlField (fslI MsgExamModeFormSynchronicity)) (fslI MsgExamModeFormSynchronicity) (examSynchronicity <$> mPrev) + <*> customPresetForm examOnlineEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examOnlinePresetWidget) (apreq htmlField (fslI MsgExamModeFormOnline)) (fslI MsgExamModeFormOnline) (examOnline <$> mPrev) + <*> customPresetForm examAidsEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examAidsPresetWidget) (apreq htmlField (fslI MsgExamModeFormAids)) (fslI MsgExamModeFormAids) (examAids <$> mPrev) + <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev) + where + examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..} + + examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset) + examAidsEither = iso examAidsToEither examAidsFromEither + where examAidsToEither (ExamAidsPreset p) = Right p + examAidsToEither (ExamAidsCustom c) = Left c + examAidsFromEither (Right p) = ExamAidsPreset p + examAidsFromEither (Left c) = ExamAidsCustom c + examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset) + examOnlineEither = iso examOnlineToEither examOnlineFromEither + where examOnlineToEither (ExamOnlinePreset p) = Right p + examOnlineToEither (ExamOnlineCustom c) = Left c + examOnlineFromEither (Right p) = ExamOnlinePreset p + examOnlineFromEither (Left c) = ExamOnlineCustom c + examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset) + examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither + where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p + examSynchronicityToEither (ExamSynchronicityCustom c) = Left c + examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p + examSynchronicityFromEither (Left c) = ExamSynchronicityCustom c + examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset) + examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither + where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p + examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c + examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p + examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c diff --git a/src/Handler/Utils/I18n.hs b/src/Handler/Utils/I18n.hs index aaf7132f4..7a8ca8c0f 100644 --- a/src/Handler/Utils/I18n.hs +++ b/src/Handler/Utils/I18n.hs @@ -1,24 +1,22 @@ module Handler.Utils.I18n ( i18nWidgetFile - , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles + , i18nWidgetFiles + , module Utils.I18n ) where import Import.NoFoundation import Foundation.Type -import Foundation.I18n + +import Utils.I18n import Language.Haskell.TH import Language.Haskell.TH.Syntax (qRunIO) -import qualified Language.Haskell.TH.Syntax as TH import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Set as Set import qualified Data.Map as Map -import qualified Data.Text as Text - import System.Directory (listDirectory) @@ -51,20 +49,6 @@ i18nWidgetFile basename = do ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] -i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text)) -i18nWidgetFilesAvailable' basename = do - let i18nDirectory = "templates" > "i18n" > basename - availableFiles <- qRunIO $ listDirectory i18nDirectory - let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles - fileKinds :: Map Text [Text] - fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ] - toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds') - - iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty - -i18nWidgetFilesAvailable :: FilePath -> Q Exp -i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable' - i18nWidgetFiles :: FilePath -> Q Exp i18nWidgetFiles basename = do availableTranslations' <- i18nWidgetFilesAvailable' basename diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index f4d146d11..7a2b1c6cc 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -4,9 +4,11 @@ module Handler.Utils.StudyFeatures , _userTableField, _userTableDegree, _userTableSemester, _userTableFieldType , UserTableStudyFeatures(..) , _UserTableStudyFeatures - , isRelevantStudyFeature + , isRelevantStudyFeature, isRelevantStudyFeatureCached + , cacheStudyFeatureRelevance , isCourseStudyFeature, courseUserStudyFeatures , isExternalExamStudyFeature, externalExamUserStudyFeatures + , isTermStudyFeature ) where import Import.NoFoundation @@ -24,6 +26,7 @@ import qualified Data.Set as Set import Data.RFC5051 (compareUnicode) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E @@ -109,8 +112,38 @@ isRelevantStudyFeature termField record studyFeatures E.where_ $ E.abs (studyFeatures' E.^. StudyFeaturesSemester E.-. studyFeatures E.^. StudyFeaturesSemester) E.==. E.val 1 E.&&. overlap studyFeatures' E.>. overlap studyFeatures +isRelevantStudyFeatureCached :: PersistEntity record + => EntityField record TermId + -> E.SqlExpr (Entity record) + -> E.SqlExpr (Entity StudyFeatures) + -> E.SqlExpr (E.Value Bool) +isRelevantStudyFeatureCached termField record studyFeatures + = E.bool calcNow useCache $ studyFeatures E.^. StudyFeaturesRelevanceCached + where + useCache + = E.exists . E.from $ \relevantStudyFeatures -> + E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesTerm E.==. record E.^. termField + E.&&. relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. studyFeatures E.^. StudyFeaturesId + calcNow = isRelevantStudyFeature termField record studyFeatures + +cacheStudyFeatureRelevance :: MonadIO m + => (E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)) + -> SqlPersistT m () +cacheStudyFeatureRelevance fFilter = do + E.insertSelectWithConflict UniqueRelevantStudyFeatures + ( E.from $ \(studyFeatures `E.InnerJoin` term) -> do + E.on E.true + E.where_ $ fFilter studyFeatures + E.where_ $ isRelevantStudyFeature TermId term studyFeatures + return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId) + ) + ( \_current _excluded -> [] ) + E.update $ \studyFeatures -> do + E.set studyFeatures [ StudyFeaturesRelevanceCached E.=. E.true ] + E.where_ $ fFilter studyFeatures + isCourseStudyFeature :: E.SqlExpr (Entity Course) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isCourseStudyFeature = isRelevantStudyFeature CourseTerm +isCourseStudyFeature = isRelevantStudyFeatureCached CourseTerm courseUserStudyFeatures :: MonadIO m => CourseId -> UserId -> SqlPersistT m UserTableStudyFeatures courseUserStudyFeatures cId uid = do @@ -130,7 +163,7 @@ courseUserStudyFeatures cId uid = do } isExternalExamStudyFeature :: E.SqlExpr (Entity ExternalExam) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) -isExternalExamStudyFeature = isRelevantStudyFeature ExternalExamTerm +isExternalExamStudyFeature = isRelevantStudyFeatureCached ExternalExamTerm externalExamUserStudyFeatures :: MonadIO m => ExternalExamId -> UserId -> SqlPersistT m UserTableStudyFeatures externalExamUserStudyFeatures eeId uid = do @@ -148,3 +181,6 @@ externalExamUserStudyFeatures eeId uid = do , userTableSemester = studyFeaturesSemester , userTableFieldType = studyFeaturesType } + +isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool) +isTermStudyFeature = isRelevantStudyFeatureCached TermId diff --git a/src/Handler/Utils/StudyFeatures/Parse.hs b/src/Handler/Utils/StudyFeatures/Parse.hs index 3001c258f..a0e749f86 100644 --- a/src/Handler/Utils/StudyFeatures/Parse.hs +++ b/src/Handler/Utils/StudyFeatures/Parse.hs @@ -43,6 +43,7 @@ pStudyFeatures studyFeaturesUser now = do studyFeaturesSuperField = Nothing studyFeaturesFirstObserved = Just now studyFeaturesLastObserved = now + studyFeaturesRelevanceCached = False return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 3d66fcace..73b6cacae 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -789,7 +789,7 @@ colStudyFeatures resultFeatures = Colonnade.singleton (fromSortable header) body fltrRelevantStudyFeaturesTerms :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesTerms queryTermUser = singletonMap "features-terms" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do - E.on $ isRelevantStudyFeature TermId term studyFeatures + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid @@ -807,7 +807,7 @@ fltrRelevantStudyFeaturesTermsUI = fltrStudyTermsUI fltrRelevantStudyFeaturesDegree :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesDegree queryTermUser = singletonMap "features-degree" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do - E.on $ isRelevantStudyFeature TermId term studyFeatures + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid @@ -826,7 +826,7 @@ fltrRelevantStudyFeaturesDegreeUI mPrev = fltrRelevantStudyFeaturesSemester :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value TermId), E.SqlExpr (E.Value UserId)) fltrRelevantStudyFeaturesSemester queryTermUser = singletonMap "features-semester" . FilterColumn $ \t criterias -> E.subSelectOr . E.from $ \(term `E.InnerJoin` studyFeatures) -> do - E.on $ isRelevantStudyFeature TermId term studyFeatures + E.on $ isTermStudyFeature term studyFeatures let (tid, uid) = t ^. queryTermUser E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. uid diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 7c03533a4..23e4f09b3 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -65,7 +65,7 @@ import Data.List as Import (elemIndex) import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Data.Semigroup as Import (Min(..), Max(..)) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..)) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..), Ap(..)) import Data.Binary as Import (Binary) import Data.Binary.Instances as Import () @@ -174,6 +174,7 @@ import System.Clock.Instances as Import () import Data.Word.Word24.Instances as Import () import Control.Monad.Trans.Memo.StateCache.Instances as Import (hoistStateCache) import Database.Persist.Sql.Types.Instances as Import () +import Control.Monad.Catch.Instances as Import () import Crypto.Hash as Import (Digest, SHA3_256, SHA3_512) import Crypto.Random as Import (ChaChaDRG, Seed) diff --git a/src/Jobs.hs b/src/Jobs.hs index 7e849400f..37428a84c 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -40,10 +40,10 @@ import qualified Control.Monad.Catch as Exc import Data.Time.Zones -import Control.Concurrent.STM (retry) +import Control.Concurrent.STM (stateTVar, retry) import Control.Concurrent.STM.Delay -import UnliftIO.Concurrent (forkIO, myThreadId) +import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) import Jobs.Handler.SendNotification @@ -68,6 +68,8 @@ import Control.Exception.Base (AsyncException) import Type.Reflection (typeOf) +import System.Clock + data JobQueueException = JInvalid QueuedJobId QueuedJob | JLocked QueuedJobId InstanceId UTCTime @@ -101,6 +103,8 @@ handleJobs foundation@UniWorX{..} jobShutdown <- liftIO newEmptyTMVarIO jobCurrentCrontab <- liftIO $ newTVarIO Nothing jobHeldLocks <- liftIO $ newTVarIO Set.empty + registerJobHeldLocksCount jobHeldLocks + registerJobWorkerQueueDepth appJobState atomically $ putTMVar appJobState JobState { jobContext = JobContext{..} , .. @@ -141,11 +145,17 @@ manageJobPool :: forall m. => UniWorX -> (forall a. m a -> m a) -> m () manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> flip runContT return . callCC $ \terminate' -> - forever . join . lift . routeExc . atomically $ asum - [ spawnMissingWorkers - , reapDeadWorkers - , terminateGracefully terminate' - ] + forever . join . lift . routeExc $ do + transferInfo <- runMaybeT $ do + moveThreshold <- hoistMaybe $ appJobMoveThreshold appSettings' + let MkFixed (fromInteger -> delayTime) = realToFrac moveThreshold / 2 :: Micro + liftIO $ (,) <$> getTime Monotonic <*> newDelay delayTime + atomically . asum $ + [ spawnMissingWorkers + , reapDeadWorkers + ] ++ maybe [] (\(cTime, delay) -> [return () <$ waitDelay delay, transferJobs cTime]) transferInfo ++ + [ terminateGracefully terminate' + ] where shutdownOnException :: ((forall m'. Monad m' => m (m' ()) -> m (m' ())) -> m a) -> m a shutdownOnException act = do @@ -191,10 +201,8 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> | shouldTerminate -> return $ return () | otherwise -> do - queue <- readTVar chan - nextVal <- case jqDequeue queue of - Nothing -> retry - Just (j, q) -> j <$ writeTVar chan q + mNext <- stateTVar chan $ \q -> maybe (Nothing, q) (over _1 Just) $ jqDequeue q + nextVal <- hoistMaybe mNext return $ yield nextVal >> streamChan runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do $logInfoS logIdent "Started" @@ -229,10 +237,11 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers' return (nextVal, receiver) whenIsJust next $ \(nextVal, receiver) -> do - atomically . modifyTVar' receiver $ jqInsert nextVal + atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) go in go + terminateGracefully :: (() -> ContT () m ()) -> STM (ContT () m ()) terminateGracefully terminate = do shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown guard shouldTerminate @@ -244,6 +253,37 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> $logInfoS "JobPoolManager" "Shutting down" terminate () + transferJobs :: TimeSpec -> STM (ContT () m ()) + transferJobs oldTime = do + moveThreshold <- hoistMaybe $ appJobMoveThreshold appSettings' + let isOld ts = oldTime - ts >= realToFrac moveThreshold + + oldState <- readTMVar appJobState + wState <- mapM readTVar $ jobWorkers oldState + + let receivers = Map.keysSet $ Map.filter ((== 0) . jqDepth) wState + senders' = Map.keysSet $ Map.filter (ianyOf jqContents $ \(_, Down qTime) _ -> isOld qTime) wState + senders = senders' `Set.difference` receivers + sendJobs = Map.restrictKeys wState senders ^.. folded . backwards jqContents . filtered jobMovable + + guard $ not (null receivers) + && not (null senders) + && not (null sendJobs) + + let movePairs = flip zip sendJobs . evalRand (uniforms receivers) . mkStdGen $ hash oldTime + + iforMOf_ (_jobWorkers .> itraversed) oldState $ \w tv -> if + | w `elem` senders + -> writeTVar tv mempty + | w `elem` receivers + -> forM_ movePairs $ \(recv, j) -> if + | recv == w -> readTVar tv >>= jqInsert j >>= (writeTVar tv $!) + | otherwise -> return () + | otherwise + -> return () + + return $ $logWarnS "JobPoolManager" [st|Moved #{tshow (olength movePairs)} long-unadressed jobs from #{tshow (olength senders)} senders to #{tshow (olength receivers)} receivers|] + stopJobCtl :: MonadUnliftIO m => UniWorX -> m () -- ^ Stop all worker threads currently running stopJobCtl UniWorX{appJobState} = do @@ -276,7 +316,7 @@ execCrontab = do | otherwise = return () runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued - mapRWST (liftHandler . runDB . setSerializable) mergeState + mapRWST (liftHandler . runDB . setSerializableBatch) mergeState refT <- liftIO getCurrentTime settings <- getsYesod appSettings' @@ -298,7 +338,7 @@ execCrontab = do atomically . writeTVar crontabTVar $ Just (now, currentCrontab') $logDebugS "Crontab" . intercalate "\n" $ "Current crontab:" : map tshow currentCrontab' - let doJob = mapRWST (liftHandler . runDBJobs . setSerializable) $ do + let doJob = mapRWST (liftHandler . runDBJobs . setSerializableBatch) $ do newCrontab <- lift $ hoist lift determineCrontab' when (newCrontab /= currentCrontab) $ mapRWST (liftIO . atomically) $ @@ -383,7 +423,7 @@ mkLogIdent :: JobWorkerId -> Text mkLogIdent wId = "Job-Executor " <> showWorkerId wId handleJobs' :: JobWorkerId -> ConduitT JobCtl Void (ReaderT JobContext Handler) () -handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do +handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorkerState wNum JobWorkerBusy $ do $logDebugS logIdent $ tshow jctl res <- fmap (either Just $ const Nothing) . withJobWorkerState wNum (JobWorkerExecJobCtl jctl) . try' $ handleCmd jctl sentRes <- mapReaderT (liftIO . atomically) $ do @@ -414,9 +454,19 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId) handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime) - handleCmd JobCtlTest = return () - handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) - handleCmd (JobCtlQueue job) = lift $ queueJob' job + handleCmd :: JobCtl -> ReaderT JobContext Handler () + handleCmd JobCtlTest = $logDebugS logIdent "JobCtlTest" + handleCmd JobCtlFlush = do + $logDebugS logIdent "JobCtlFlush..." + heldLocks <- asks jobHeldLocks >>= readTVarIO + void . lift . runDB . runConduit + $ selectKeys [ QueuedJobId /<-. Set.toList heldLocks ] [ Asc QueuedJobCreationTime ] + .| C.mapM_ (\j -> lift $ runReaderT (writeJobCtl $ JobCtlPerform j) =<< getYesod) + $logInfoS logIdent "JobCtlFlush" + handleCmd (JobCtlQueue job) = do + $logDebugS logIdent "JobCtlQueue..." + lift $ queueJob' job + $logInfoS logIdent "JobCtlQueue" handleCmd (JobCtlPerform jId) = handle handleQueueException . jLocked jId $ \(Entity _ j@QueuedJob{..}) -> lift $ do content <- case fromJSON queuedJobContent of Aeson.Success c -> return c @@ -445,36 +495,49 @@ handleJobs' wNum = C.mapM_ $ \jctl -> withJobWorkerState wNum JobWorkerBusy $ do delete jId case performJob content of - JobHandlerAtomic act -> runDBJobs . setSerializable $ do + JobHandlerAtomic act -> runDBJobs . setSerializableBatch $ do act & withJobWorkerState wNum (JobWorkerExecJob content) hoist lift cleanup JobHandlerException act -> do act & withJobWorkerState wNum (JobWorkerExecJob content) - runDB $ setSerializable cleanup + runDB $ setSerializableBatch cleanup + JobHandlerAtomicWithFinalizer act fin -> do + res <- runDBJobs . setSerializableBatch $ do + res <- act & withJobWorkerState wNum (JobWorkerExecJob content) + hoist lift cleanup + return res + fin res handleCmd JobCtlDetermineCrontab = do - newCTab <- liftHandler . runDB $ setSerializable determineCrontab' + $logDebugS logIdent "DetermineCrontab..." + newCTab <- liftHandler . runDB $ setSerializableBatch determineCrontab' + $logInfoS logIdent "DetermineCrontab" -- logDebugS logIdent $ tshow newCTab mapReaderT (liftIO . atomically) $ lift . void . flip swapTVar newCTab =<< asks jobCrontab handleCmd (JobCtlGenerateHealthReport kind) = do hrStorage <- getsYesod appHealthReport + $logDebugS logIdent [st|#{tshow kind}...|] newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind - $logInfoS (tshow kind) $ toPathPiece newStatus + $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] unless (newStatus == HealthSuccess) $ do - $logErrorS (tshow kind) $ tshow newReport + $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] liftIO $ do now <- getCurrentTime let updateReports = Set.insert (now, newReport) . Set.filter (((/=) `on` classifyHealthReport) newReport . snd) atomically . modifyTVar' hrStorage $ force . updateReports + handleCmd (JobCtlSleep secs@(MkFixed (fromIntegral -> msecs))) = do + $logInfoS logIdent [st|Sleeping #{tshow secs}s...|] + threadDelay msecs + $logInfoS logIdent [st|Slept #{tshow secs}s.|] jLocked :: QueuedJobId -> (Entity QueuedJob -> ReaderT JobContext Handler a) -> ReaderT JobContext Handler a jLocked jId act = flip evalStateT False $ do let lock :: StateT Bool (ReaderT JobContext Handler) (Entity QueuedJob) - lock = hoist (hoist $ runDB . setSerializable) $ do + lock = hoist (hoist $ runDB . setSerializableBatch) $ do qj@QueuedJob{..} <- lift . lift $ maybe (throwM $ JNonexistant jId) return =<< get jId instanceID' <- getsYesod $ view instanceID threshold <- getsYesod $ view _appJobStaleThreshold @@ -503,7 +566,7 @@ jLocked jId act = flip evalStateT False $ do unlock :: Entity QueuedJob -> StateT Bool (ReaderT JobContext Handler) () unlock (Entity jId' _) = whenM State.get $ do atomically . flip modifyTVar' (Set.delete jId') =<< asks jobHeldLocks - lift . lift . runDB . setSerializable $ + lift . lift . runDB . setSerializableBatch $ update jId' [ QueuedJobLockInstance =. Nothing , QueuedJobLockTime =. Nothing ] diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 8127e16e8..1663cb2fc 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -100,6 +100,15 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + tell $ HashMap.singleton + (JobCtlQueue JobDetectMissingFiles) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = 7200 + , cronNotAfter = Right CronNotScheduled + } + tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of Just int -> HashMap.singleton diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index 55218e170..6fa139a45 100644 --- a/src/Jobs/Handler/Files.hs +++ b/src/Jobs/Handler/Files.hs @@ -1,7 +1,12 @@ +{-# OPTIONS_GHC -Wno-error=deprecations #-} + +{-# LANGUAGE BangPatterns #-} + module Jobs.Handler.Files ( dispatchJobPruneSessionFiles , dispatchJobPruneUnreferencedFiles , dispatchJobInjectFiles, dispatchJobRechunkFiles + , dispatchJobDetectMissingFiles ) where import Import hiding (matching, maximumBy, init) @@ -26,19 +31,29 @@ import Data.Bits (Bits(shiftR)) import qualified Data.Map.Strict as Map -import Control.Monad.Random.Lazy +import Control.Monad.Random.Lazy (evalRand, mkStdGen) import System.Random.Shuffle (shuffleM) import System.IO.Unsafe import Handler.Utils.Files (sourceFileDB) +import Control.Monad.Logger (askLoggerIO, runLoggingT) + +import System.Clock + +import qualified Data.Set as Set + +import Jobs.Queue (YesodJobDB) + dispatchJobPruneSessionFiles :: JobHandler UniWorX -dispatchJobPruneSessionFiles = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - expires <- getsYesod $ view _appSessionFilesExpire - n <- deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] - $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] +dispatchJobPruneSessionFiles = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appSessionFilesExpire + deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] + fin n = $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] @@ -59,147 +74,213 @@ fileReferences (E.just -> fHash) ] +dispatchJobDetectMissingFiles :: JobHandler UniWorX +dispatchJobDetectMissingFiles = JobHandlerAtomicWithFinalizer act fin + where + act :: YesodJobDB UniWorX (Map Text (NonNull (Set FileContentReference))) + act = hoist lift $ do + uploadBucket <- getsYesod $ view _appUploadCacheBucket + + missingDb <- forM trackedReferences $ \refQuery -> + fmap (Set.fromList . mapMaybe E.unValue) . E.select $ do + ref <- refQuery + E.where_ . E.not_ $ E.isNothing ref + E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> + E.where_ $ E.just (fileContentEntry E.^. FileContentEntryHash) E.==. ref + E.distinctOnOrderBy [E.asc ref] $ return ref + + let allMissingDb :: Set Minio.Object + allMissingDb = setOf (folded . folded . re minioFileReference) missingDb + filterMissingDb :: forall m. Monad m + => Set Minio.Object + -> ConduitT Minio.ListItem (Set Minio.Object) m () + filterMissingDb remaining = maybeT (yield remaining) $ do + nextMinio <- MaybeT await + remaining' <- case nextMinio of + Minio.ListItemObject oi -> do + let (missingMinio, remaining') = Set.split (Minio.oiObject oi) remaining + lift $ yield missingMinio + return remaining' + _other -> return remaining + lift $ filterMissingDb remaining' + + allMissingMinio <- maybeT (return $ fold missingDb) . hoistMaybeM . runAppMinio . runMaybeT . runConduit $ + transPipe lift (Minio.listObjects uploadBucket Nothing True) + .| filterMissingDb allMissingDb + .| C.foldMapE (setOf minioFileReference) + + return $ Map.mapMaybe (fromNullable . Set.intersection allMissingMinio) missingDb + + fin :: Map Text (NonNull (Set FileContentReference)) -> Handler () + fin missingCounts = do + forM_ (Map.keysSet trackedReferences) $ \refIdent -> + observeMissingFiles refIdent . maybe 0 olength $ missingCounts Map.!? refIdent + + iforM_ missingCounts $ \refIdent missingFiles + -> let missingRefs = unlines . map tshow . Set.toList $ toNullable missingFiles + in $logErrorS "MissingFiles" [st|#{refIdent}: #{olength missingFiles}\n#{missingRefs}|] + + when (Map.null missingCounts) $ + $logInfoS "MissingFiles" [st|No missing files|] + + trackedReferences = Map.fromList $ over (traverse . _1) nameToPathPiece + [ (''CourseApplicationFile, E.from $ \appFile -> return $ appFile E.^. CourseApplicationFileContent ) + , (''MaterialFile, E.from $ \matFile -> return $ matFile E.^. MaterialFileContent ) + , (''CourseNewsFile, E.from $ \newsFile -> return $ newsFile E.^. CourseNewsFileContent ) + , (''SheetFile, E.from $ \sheetFile -> return $ sheetFile E.^. SheetFileContent ) + , (''CourseAppInstructionFile, E.from $ \appInstr -> return $ appInstr E.^. CourseAppInstructionFileContent) + , (''SubmissionFile, E.from $ \subFile -> return $ subFile E.^. SubmissionFileContent ) + , (''SessionFile, E.from $ \sessFile -> return $ sessFile E.^. SessionFileContent ) + , (''AllocationMatching, E.from $ \matching -> return . E.just $ matching E.^. AllocationMatchingLog ) + ] + + + {-# NOINLINE pruneUnreferencedFilesIntervalsCache #-} pruneUnreferencedFilesIntervalsCache :: TVar (Map Natural [(Maybe FileContentChunkReference, Maybe FileContentChunkReference)]) pruneUnreferencedFilesIntervalsCache = unsafePerformIO $ newTVarIO Map.empty dispatchJobPruneUnreferencedFiles :: Natural -> Natural -> Natural -> JobHandler UniWorX -dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - interval <- getsYesod $ view _appPruneUnreferencedFilesInterval - keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles +dispatchJobPruneUnreferencedFiles numIterations epoch iteration = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + interval <- getsYesod $ view _appPruneUnreferencedFilesInterval + keep <- fmap (max 0) . getsYesod $ view _appKeepUnreferencedFiles - let - chunkHashBytes :: forall h. - ( Unwrapped FileContentChunkReference ~ Digest h ) - => Integer - chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) - chunkHashBits = chunkHashBytes * 8 - base :: Integer - base = 2 ^ chunkHashBits - intervals :: [Integer] - -- | Exclusive upper bounds - intervals - | numIterations <= 0 = pure base - | otherwise = go protoIntervals ^.. folded . _1 - where - go [] = [] - go ints - | maximumOf (folded . _1) ints == Just base = ints - | otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts - where - closest = maximumBy (comparing $ view _2) ints - (lts, geqs) = partition (((>) `on` view _1) closest) ints - gts = filter (((<) `on` view _1) closest) geqs + let + chunkHashBytes :: forall h. + ( Unwrapped FileContentChunkReference ~ Digest h ) + => Integer + chunkHashBytes = fromIntegral (hashDigestSize (error "hashDigestSize inspected argument" :: h)) + chunkHashBits = chunkHashBytes * 8 + base :: Integer + base = 2 ^ chunkHashBits + intervals :: [Integer] -- | Exclusive upper bounds - protoIntervals :: [(Integer, Integer)] - protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations - | i <- [1 .. toInteger numIterations] - ] + intervals + | numIterations <= 0 = pure base + | otherwise = go protoIntervals ^.. folded . _1 + where + go [] = [] + go ints + | maximumOf (folded . _1) ints == Just base = ints + | otherwise = go $ lts ++ over _1 succ (over _2 (subtract $ toInteger numIterations) closest) : map (over _1 succ) gts + where + closest = maximumBy (comparing $ view _2) ints + (lts, geqs) = partition (((>) `on` view _1) closest) ints + gts = filter (((<) `on` view _1) closest) geqs + -- | Exclusive upper bounds + protoIntervals :: [(Integer, Integer)] + protoIntervals = [ over _1 (i *) $ base `divMod` toInteger numIterations + | i <- [1 .. toInteger numIterations] + ] - intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals + intervalsDgsts' = zipWith (curry . over both $ toDigest <=< assertM' (> 0)) (0 : init intervals) intervals - toDigest :: Integer -> Maybe FileContentChunkReference - toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step - where step i - | i <= 0 = Nothing - | otherwise = Just (fromIntegral i, i `shiftR` 8) - pad bs - | toInteger (ByteString.length bs) >= chunkHashBytes = bs - | otherwise = pad $ ByteString.cons 0 bs + toDigest :: Integer -> Maybe FileContentChunkReference + toDigest = fmap (review _Wrapped) . digestFromByteString . pad . ByteString.pack . reverse . unfoldr step + where step i + | i <= 0 = Nothing + | otherwise = Just (fromIntegral i, i `shiftR` 8) + pad bs + | toInteger (ByteString.length bs) >= chunkHashBytes = bs + | otherwise = pad $ ByteString.cons 0 bs - intervalsDgsts <- atomically $ do - cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache - case Map.lookup numIterations cachedDgsts of - Just c -> return c - Nothing -> do - modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts' - return intervalsDgsts' + intervalsDgsts <- atomically $ do + cachedDgsts <- readTVar pruneUnreferencedFilesIntervalsCache + case Map.lookup numIterations cachedDgsts of + Just c -> return c + Nothing -> do + modifyTVar' pruneUnreferencedFilesIntervalsCache $ force . Map.insert numIterations intervalsDgsts' + return intervalsDgsts' - let - permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch) - - (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts) - chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool) - chunkIdFilter cRef = E.and $ catMaybes - [ minBoundDgst <&> \b -> cRef E.>=. E.val b - , maxBoundDgst <&> \b -> cRef E.<. E.val b - ] + let + permIntervalsDgsts = shuffleM intervalsDgsts `evalRand` mkStdGen (hash epoch) - $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst) - - E.insertSelectWithConflict - (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint") - (E.from $ \fileContentChunk -> do - E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId + (minBoundDgst, maxBoundDgst) = permIntervalsDgsts !! fromIntegral (toInteger iteration `mod` genericLength permIntervalsDgsts) + chunkIdFilter :: E.SqlExpr (E.Value FileContentChunkReference) -> E.SqlExpr (E.Value Bool) + chunkIdFilter cRef = E.and $ catMaybes + [ minBoundDgst <&> \b -> cRef E.>=. E.val b + , maxBoundDgst <&> \b -> cRef E.<. E.val b + ] + + $logDebugS "PruneUnreferencedFiles" . tshow $ (minBoundDgst, maxBoundDgst) + + E.insertSelectWithConflict + (UniqueFileContentChunkUnreferenced $ error "insertSelectWithConflict inspected constraint") + (E.from $ \fileContentChunk -> do + E.where_ . E.not_ . E.subSelectOr . E.from $ \fileContentEntry -> do + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunk E.^. FileContentChunkId + return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash + E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash + return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now + ) + (\current excluded -> + [ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ] + ) + + E.delete . E.from $ \fileContentChunkUnreferenced -> do + E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ fileContentChunk E.^. FileContentChunkHash - return $ FileContentChunkUnreferenced E.<# (fileContentChunk E.^. FileContentChunkId) E.<&> E.val now - ) - (\current excluded -> - [ FileContentChunkUnreferencedSince E.=. E.min (current E.^. FileContentChunkUnreferencedSince) (excluded E.^. FileContentChunkUnreferencedSince) ] - ) + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - E.delete . E.from $ \fileContentChunkUnreferenced -> do - E.where_ . E.subSelectOr . E.from $ \fileContentEntry -> do - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - return . E.any E.exists . fileReferences $ fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + let + getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do + let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do + E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince + E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince - let - getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> do - let unreferencedSince = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunkUnreferenced) -> do - E.on $ fileContentEntry' E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - return . E.max_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince - E.where_ $ E.maybe E.false (E.<. E.val (addUTCTime (-keep) now)) unreferencedSince + E.groupBy $ fileContentEntry E.^. FileContentEntryHash + E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ] - E.groupBy $ fileContentEntry E.^. FileContentEntryHash - E.orderBy [ E.asc $ fileContentEntry E.^. FileContentEntryHash ] - - return $ fileContentEntry E.^. FileContentEntryHash + return $ fileContentEntry E.^. FileContentEntryHash - deleteEntry :: _ -> DB (Sum Natural) - deleteEntry (E.Value fRef) = - bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef] - - Sum deletedEntries <- runConduit $ - getEntryCandidates - .| takeWhileTime (interval / 3) - .| C.mapM deleteEntry - .| C.fold - - when (deletedEntries > 0) $ - $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|] - - let - getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do - E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now) - E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> - E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - - E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) + deleteEntry :: _ -> DB (Sum Natural) + deleteEntry (E.Value fRef) = + bool 0 1 . (> 0) <$> deleteWhereCount [FileContentEntryHash ==. fRef] - return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) - ) + Sum deletedEntries <- runConduit $ + getEntryCandidates + .| takeWhileTime (interval / 3) + .| C.mapM deleteEntry + .| C.fold - deleteChunk :: _ -> DB (Sum Natural, Sum Word64) - deleteChunk (E.Value cRef, E.Value size) = do - deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ] - (, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef] + let + getChunkCandidates = E.selectSource . E.from $ \fileContentChunkUnreferenced -> do + E.where_ $ fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedSince E.<. E.val (addUTCTime (-keep) now) + E.where_ . E.not_ . E.exists . E.from $ \fileContentEntry -> + E.where_ $ fileContentEntry E.^. FileContentEntryChunkHash E.==. fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash - (Sum deletedChunks, Sum deletedChunkSize) <- runConduit $ - getChunkCandidates - .| takeWhileTime (interval / 3) - .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64) - .| C.mapM deleteChunk - .| C.fold + E.where_ . chunkIdFilter $ E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash (E.^. FileContentChunkHash) - when (deletedChunks > 0) $ - $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{tshow deletedChunkSize} bytes)|] + return ( fileContentChunkUnreferenced E.^. FileContentChunkUnreferencedHash + , E.subSelectForeign fileContentChunkUnreferenced FileContentChunkUnreferencedHash $ E.length_ . (E.^. FileContentChunkContent) + ) + + deleteChunk :: _ -> DB (Sum Natural, Sum Word64) + deleteChunk (E.Value cRef, E.Value size) = do + deleteWhere [ FileContentChunkUnreferencedHash ==. cRef ] + (, Sum size) . fromIntegral <$> deleteWhereCount [FileContentChunkHash ==. unFileContentChunkKey cRef] + + (Sum deletedChunks, Sum deletedChunkSize) <- runConduit $ + getChunkCandidates + .| takeWhileTime (interval / 3) + .| persistentTokenBucketTakeC' TokenBucketPruneFiles (view $ _2 . _Value :: _ -> Word64) + .| C.mapM deleteChunk + .| C.fold + + return (deletedEntries, deletedChunks, deletedChunkSize) + + fin (deletedEntries, deletedChunks, deletedChunkSize) = do + observeDeletedUnreferencedFiles deletedEntries + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedEntries} long-unreferenced files|] + observeDeletedUnreferencedChunks deletedChunks deletedChunkSize + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{tshow deletedChunks} chunks (#{textBytes deletedChunkSize})|] dispatchJobInjectFiles :: JobHandler UniWorX @@ -211,18 +292,50 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do extractReference (Minio.ListItemObject oi) = (oi, ) <$> Minio.oiObject oi ^? minioFileReference extractReference _ = Nothing - injectOrDelete :: (Minio.Object, FileContentReference) - -> Handler (Sum Int64) -- ^ Injected - injectOrDelete (obj, fRef) = do - fRef' <- runDB . setSerializable $ do + injectOrDelete :: (Minio.ObjectInfo, FileContentReference) + -> Handler (Sum Natural, Sum Word64) + injectOrDelete (objInfo, fRef) = do + let obj = Minio.oiObject objInfo + sz = fromIntegral $ Minio.oiSize objInfo + + fRef' <- runDB $ do chunkVar <- newEmptyTMVarIO dbAsync <- allocateLinkedAsync $ do atomically $ isEmptyTMVar chunkVar >>= guard . not sinkFileDB False $ C.unfoldM (\x -> fmap (, x) <$> atomically (takeTMVar chunkVar)) () + logger <- askLoggerIO didSend <- maybeT (return False) . hoistMaybeM . runAppMinio . runMaybeT $ do objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions - lift . runConduit $ Minio.gorObjectStream objRes .| C.mapM_ (atomically . putTMVar chunkVar . Just) + let sendChunks = go 0 0 Nothing =<< liftIO (getTime Monotonic) + where + go :: forall m. MonadIO m => Natural -> Int64 -> Maybe TimeSpec -> TimeSpec -> ConduitT ByteString Void m () + go c accsz lastReport startT = do + currT <- liftIO $ getTime Monotonic + chunk' <- await + whenIsJust chunk' $ \chunk -> do + let csz = fromIntegral $ olength chunk + !c' = succ c + !sz' = accsz + csz + !lastReport' + | toRational currT - toRational (fromMaybe startT lastReport) > 5 = Just currT + | otherwise = lastReport + when (csz > 0) $ do + let p :: Centi + p = realToFrac $ (toInteger sz' % toInteger sz) * 100 + eta :: Maybe Integer + eta = do + accsz' <- assertM' (/= 0) accsz + return . ceiling $ (toRational currT - toRational startT) / fromIntegral accsz' * (fromIntegral sz - fromIntegral accsz) + when (lastReport' /= lastReport || sz' >= fromIntegral sz) $ + flip runLoggingT logger . $logInfoS "InjectFiles" . mconcat $ catMaybes + [ pure [st|Sinking chunk ##{tshow c} (#{textBytes csz}): #{textBytes sz'}/#{textBytes sz} (#{tshow p}%)|] + , eta <&> \eta' -> [st| ETA #{textDuration eta'}|] + , pure "..." + ] + atomically . putTMVar chunkVar $ Just chunk + go c' sz' lastReport' startT + lift . runConduit $ Minio.gorObjectStream objRes .| sendChunks return True if | not didSend -> Nothing <$ cancel dbAsync @@ -234,19 +347,18 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do maybeT (return ()) . runAppMinio . handleIf minioIsDoesNotExist (const $ return ()) $ Minio.removeObject uploadBucket obj | otherwise -> $logErrorS "InjectFiles" [st|Minio object “#{obj}”'s content does not match it's name (content hash: #{tshow fRef'} /= name hash: #{tshow fRef})|] - return . bool mempty (Sum 1) $ is _Just fRef' + return . bool mempty (Sum 1, Sum sz) $ is _Just fRef' - Sum inj <- + (Sum injectedFiles, Sum injectedSize) <- runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True) .| C.mapMaybe extractReference .| maybe (C.map id) (takeWhileTime . (/ 2)) interval .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize) - .| C.map (over _1 Minio.oiObject) - .| transPipe lift (C.mapM injectOrDelete) + .| C.mapM (lift . injectOrDelete) + .| C.mapM (\res@(Sum inj, Sum sz) -> res <$ observeInjectedFiles inj sz) .| C.fold - when (inj > 0) $ - $logInfoS "InjectFiles" [st|Injected #{inj} files from upload cache into database|] + $logInfoS "InjectFiles" [st|Injected #{tshow injectedFiles} files from upload cache into database (#{textBytes injectedSize})|] data RechunkFileException @@ -256,38 +368,42 @@ data RechunkFileException deriving anyclass (Exception) dispatchJobRechunkFiles :: JobHandler UniWorX -dispatchJobRechunkFiles = JobHandlerAtomic . hoist lift $ do - interval <- getsYesod $ view _appRechunkFiles - let - getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do - E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do - E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash - E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased - - let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do +dispatchJobRechunkFiles = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + interval <- getsYesod $ view _appRechunkFiles + let + getEntryCandidates = E.selectSource . E.from $ \fileContentEntry -> E.distinctOnOrderBy [E.asc $ fileContentEntry E.^. FileContentEntryHash] $ do + E.where_ . E.exists . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash - return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) - - return ( fileContentEntry E.^. FileContentEntryHash - , size - ) + E.where_ . E.not_ $ fileContentChunk E.^. FileContentChunkContentBased - rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64) - rechunkFile fRef sz = do - fRef' <- sinkFileDB True $ sourceFileDB fRef - unless (fRef == fRef') $ - throwM $ RechunkFileExceptionHashMismatch fRef fRef' - return (Sum 1, Sum sz) + let size = E.subSelectMaybe . E.from $ \(fileContentEntry' `E.InnerJoin` fileContentChunk) -> do + E.on $ fileContentChunk E.^. FileContentChunkId E.==. fileContentEntry' E.^. FileContentEntryChunkHash + E.where_ $ fileContentEntry' E.^. FileContentEntryHash E.==. fileContentEntry E.^. FileContentEntryHash + return $ E.sum_ (E.length_ $ fileContentChunk E.^. FileContentChunkContent:: E.SqlExpr (E.Value Word64)) - (Sum rechunkedEntries, Sum rechunkedSize) <- runConduit $ - getEntryCandidates - .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) - .| maybe (C.map id) (takeWhileTime . (/ 2)) interval - .| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64) - .| C.mapM (uncurry rechunkFile) - .| C.fold - - when (rechunkedEntries > 0 || rechunkedSize > 0) $ - $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedEntries} files in database (#{tshow rechunkedSize} bytes)|] + return ( fileContentEntry E.^. FileContentEntryHash + , size + ) + + rechunkFile :: FileContentReference -> Word64 -> DB (Sum Natural, Sum Word64) + rechunkFile fRef sz = do + fRef' <- sinkFileDB True $ sourceFileDB fRef + unless (fRef == fRef') $ + throwM $ RechunkFileExceptionHashMismatch fRef fRef' + return (Sum 1, Sum sz) + + (Sum rechunkedFiles, Sum rechunkedSize) <- runConduit $ + getEntryCandidates + .| C.mapMaybe (\(E.Value fRef, E.Value sz) -> (fRef, ) <$> sz) + .| maybe (C.map id) (takeWhileTime . (/ 2)) interval + .| persistentTokenBucketTakeC' TokenBucketRechunkFiles (view _2 :: _ -> Word64) + .| C.mapM (uncurry rechunkFile) + .| C.fold + + return (rechunkedFiles, rechunkedSize) + fin (rechunkedFiles, rechunkedSize) = do + observeRechunkedFiles rechunkedFiles rechunkedSize + $logInfoS "RechunkFiles" [st|Rechunked #{tshow rechunkedFiles} files in database (#{textBytes rechunkedSize} bytes)|] diff --git a/src/Jobs/Handler/PersonalisedSheetFiles.hs b/src/Jobs/Handler/PersonalisedSheetFiles.hs index 35bd8cd61..af906e61f 100644 --- a/src/Jobs/Handler/PersonalisedSheetFiles.hs +++ b/src/Jobs/Handler/PersonalisedSheetFiles.hs @@ -8,8 +8,10 @@ import Database.Persist.Sql (deleteWhereCount) dispatchJobPruneFallbackPersonalisedSheetFilesKeys :: JobHandler UniWorX -dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire - n <- deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] - $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] +dispatchJobPruneFallbackPersonalisedSheetFilesKeys = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appFallbackPersonalisedSheetFilesKeysExpire + deleteWhereCount [ FallbackPersonalisedSheetFilesKeyGenerated <. addUTCTime (- expires) now ] + fin n = $logInfoS "PruneFallbackPersonalisedSheetFilesKeys" [st|Deleted #{n} expired fallback personalised sheet files keys|] diff --git a/src/Jobs/Handler/PruneInvitations.hs b/src/Jobs/Handler/PruneInvitations.hs index e7516f204..756b56d0a 100644 --- a/src/Jobs/Handler/PruneInvitations.hs +++ b/src/Jobs/Handler/PruneInvitations.hs @@ -7,7 +7,9 @@ import Import import Database.Persist.Sql (deleteWhereCount) dispatchJobPruneInvitations :: JobHandler UniWorX -dispatchJobPruneInvitations = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - n <- deleteWhereCount [ InvitationExpiresAt <. Just now ] - $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] +dispatchJobPruneInvitations = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + deleteWhereCount [ InvitationExpiresAt <. Just now ] + fin n = $logInfoS "PruneInvitations" [st|Deleted #{n} expired invitations|] diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 38fa2a3f0..f671b0c71 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -14,6 +14,7 @@ import qualified Data.Set as Set import Handler.Utils.ExamOffice.Exam import Handler.Utils.ExamOffice.ExternalExam +import Handler.Utils.Allocation (allocationNotifyNewCourses) import qualified Data.Conduit.Combinators as C @@ -22,21 +23,24 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX dispatchJobQueueNotification jNotification = JobHandlerAtomic $ runConduit $ yield jNotification .| transPipe (hoist lift) determineNotificationCandidates - .| C.filterM (\(notification', Entity _ User{userNotificationSettings}) -> notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) - .| C.map (\(notification', Entity uid _) -> JobSendNotification uid notification') + .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings}) -> or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification')) + .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification') .| sinkDBJobs -determineNotificationCandidates :: ConduitT Notification (Notification, Entity User) DB () +determineNotificationCandidates :: ConduitT Notification (Notification, Bool, Entity User) DB () determineNotificationCandidates = awaitForever $ \notif -> do - let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Entity User) DB () - withNotif c = toProducer c .| C.map (notif, ) + let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB () + withNotif c = toProducer c .| C.map (notif, False, ) + + withNotifOverride :: ConduitT () (E.Value Bool, Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB () + withNotifOverride c = toProducer c .| C.map (\(E.Value override, user) -> (notif, override, user)) -- | Assumes that conduit produces output sorted by `UserId` separateTargets :: Ord target => (Set target -> Notification) -> ConduitT () (Entity User, E.Value target) DB () - -> ConduitT Notification (Notification, Entity User) DB () + -> ConduitT Notification (Notification, Bool, Entity User) DB () separateTargets mkNotif' c = toProducer c .| go Nothing Set.empty where go Nothing _ = do next <- await @@ -46,10 +50,10 @@ determineNotificationCandidates = awaitForever $ \notif -> do go (Just uent) ts = do next <- await case next of - Nothing -> yield (mkNotif' ts, uent) + Nothing -> yield (mkNotif' ts, False, uent) Just next'@(uent', E.Value t) | ((==) `on` entityKey) uent uent' -> go (Just uent) $ Set.insert t ts - | otherwise -> yield (mkNotif' ts, uent) >> leftover next' >> go Nothing Set.empty + | otherwise -> yield (mkNotif' ts, False, uent) >> leftover next' >> go Nothing Set.empty case notif of NotificationSubmissionRated{..} @@ -281,6 +285,21 @@ determineNotificationCandidates = awaitForever $ \notif -> do -> withNotif . yieldMMany $ getEntity nUser NotificationSubmissionUserDeleted{..} -> withNotif . yieldMMany $ getEntity nUser + NotificationAllocationNewCourse{..} + -> withNotifOverride . E.selectSource . E.from $ \user -> do + let hasOverride = E.exists . E.from $ \allocationNotificationSetting -> + E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. user E.^. UserId + E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. E.val nAllocation + E.&&. E.not_ (allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut) + + E.where_ . allocationNotifyNewCourses (E.val nAllocation) $ user E.^. UserId + + E.where_ . E.not_ . E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + E.&&. application E.^. CourseApplicationCourse E.==. E.val nCourse + + return (hasOverride, user) classifyNotification :: Notification -> DB NotificationTrigger @@ -315,3 +334,4 @@ classifyNotification NotificationCourseRegistered{} = return NTCou classifyNotification NotificationSubmissionEdited{} = return NTSubmissionEdited classifyNotification NotificationSubmissionUserCreated{} = return NTSubmissionUserCreated classifyNotification NotificationSubmissionUserDeleted{} = return NTSubmissionUserDeleted +classifyNotification NotificationAllocationNewCourse{} = return NTAllocationNewCourse diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index 0f9a50741..24c517239 100644 --- a/src/Jobs/Handler/SendNotification/Allocation.hs +++ b/src/Jobs/Handler/SendNotification/Allocation.hs @@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.Allocation , dispatchNotificationAllocationAllocation , dispatchNotificationAllocationUnratedApplications , dispatchNotificationAllocationResults + , dispatchNotificationAllocationNewCourse ) where import Import @@ -183,3 +184,24 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi editNotifications <- mkEditNotifications jRecipient addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet") + +dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler () +dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do + (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,) + <$> getJust nAllocation + <*> getJust nCourse + <*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient] + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName + editNotifications <- mkEditNotifications jRecipient + + cID <- encrypt nCourse + mayApply <- orM + [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True + , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True + ] + + allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID + + addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet") diff --git a/src/Jobs/Handler/TransactionLog.hs b/src/Jobs/Handler/TransactionLog.hs index 131ba2491..ae8d8fa96 100644 --- a/src/Jobs/Handler/TransactionLog.hs +++ b/src/Jobs/Handler/TransactionLog.hs @@ -9,23 +9,27 @@ import Handler.Utils.DateTime import Database.Persist.Sql (updateWhereCount, deleteWhereCount) dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: JobHandler UniWorX -dispatchJobTruncateTransactionLog = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - let localNow = utcToLocalTime now - (localCurrentYear, _, _) = toGregorian $ localDay localNow - localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight - (currentYear, _, _) = toGregorian $ utctDay now - startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0 - startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of - LTUUnique utc' _ -> utc' - _other -> startOfPreviousYear +dispatchJobTruncateTransactionLog = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + let localNow = utcToLocalTime now + (localCurrentYear, _, _) = toGregorian $ localDay localNow + localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight + (currentYear, _, _) = toGregorian $ utctDay now + startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0 + startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of + LTUUnique utc' _ -> utc' + _other -> startOfPreviousYear - n <- deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ] - $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|] -dispatchJobDeleteTransactionLogIPs = JobHandlerAtomic . hoist lift $ do - now <- liftIO getCurrentTime - retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime - let cutoff = addUTCTime (- retentionTime) now + deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ] + fin n = $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|] +dispatchJobDeleteTransactionLogIPs = JobHandlerAtomicWithFinalizer act fin + where + act = hoist lift $ do + now <- liftIO getCurrentTime + retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime + let cutoff = addUTCTime (- retentionTime) now - n <- updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ] - $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|] + updateWhereCount [ TransactionLogTime <. cutoff, TransactionLogRemote !=. Nothing ] [ TransactionLogRemote =. Nothing ] + fin n = $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|] diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index bb2faf762..0a495194b 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -30,6 +30,8 @@ import UnliftIO.Concurrent (myThreadId) import Control.Monad.Trans.Resource (register) +import System.Clock (getTime, Clock(Monotonic)) + data JobQueueException = JobQueuePoolEmpty | JobQueueWorkerNotFound @@ -46,7 +48,7 @@ writeJobCtl' target cmd = do | null jobWorkers -> throwM JobQueuePoolEmpty | [(_, chan)] <- filter ((== target) . jobWorkerName . view _1) $ Map.toList jobWorkers - -> atomically . modifyTVar' chan $ jqInsert cmd + -> atomically $ readTVar chan >>= jqInsert cmd >>= (writeTVar chan $!) | otherwise -> throwM JobQueueWorkerNotFound @@ -56,27 +58,35 @@ writeJobCtl :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m ( -- Instructions are assigned deterministically and pseudo-randomly to one specific worker. -- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others writeJobCtl cmd = do - names <- fmap jobWorkerNames $ asks appJobState >>= atomically . readTMVar + jSt <- asks appJobState + names <- atomically $ jobWorkerNames <$> readTMVar jSt + when (null names) $ throwM JobQueuePoolEmpty tid <- myThreadId - let target = evalRand ?? mkStdGen (hash tid `hashWithSalt` cmd) $ uniform names + cTime <- liftIO $ getTime Monotonic + let + epoch :: Int64 + epoch = round cTime `div` 3600 + target = evalRand ?? mkStdGen (hash epoch `hashWithSalt` tid `hashWithSalt` cmd) $ uniform names writeJobCtl' target cmd -writeJobCtlBlock' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m () +writeJobCtlBlock' :: (MonadMask m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m () -- | Pass an instruction to a `Job`-Worker using the provided callback and block until it was acted upon writeJobCtlBlock' writeCtl cmd = do getResVar <- fmap (jobConfirm . jobContext) $ asks appJobState >>= atomically . readTMVar - resVar <- atomically $ do - var <- newEmptyTMVar - modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) - return var - writeCtl cmd - let - removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd - mExc <- atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar - maybe (return ()) throwM mExc -writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () + let getResVar' = atomically $ do + var <- newEmptyTMVar + modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var) + return var + removeResVar resVar = modifyTVar' getResVar $ HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd + + bracket getResVar' (atomically . removeResVar) $ \resVar -> do + writeCtl cmd + mExc <- atomically $ takeTMVar resVar <* removeResVar resVar + maybe (return ()) throwM mExc + +writeJobCtlBlock :: (MonadMask m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m () -- | Pass an instruction to the `Job`-Workers and block until it was acted upon writeJobCtlBlock = writeJobCtlBlock' writeJobCtl diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 59a15c99a..831d73366 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -9,15 +9,14 @@ module Jobs.Types , YesodJobDB , JobHandler(..), _JobHandlerAtomic, _JobHandlerException , JobContext(..) - , JobState(..) + , JobState(..), _jobWorkers, _jobWorkerName, _jobContext, _jobPoolManager, _jobCron, _jobShutdown, _jobCurrentCrontab , jobWorkerNames - , JobWorkerState(..) - , withJobWorkerState + , JobWorkerState(..), _jobWorkerJobCtl, _jobWorkerJob , JobWorkerId , showWorkerId, newWorkerId - , JobQueue, jqInsert, jqDequeue + , JobQueue, jqInsert, jqDequeue', jqDequeue, jqDepth, jqContents , JobPriority(..), prioritiseJob - , jobNoQueueSame + , jobNoQueueSame, jobMovable , module Cron ) where @@ -38,89 +37,92 @@ import qualified Data.Set as Set import Data.PQueue.Prio.Max (MaxPQueue) import qualified Data.PQueue.Prio.Max as PQ -import Utils.Metrics (withJobWorkerStateLbls) - -import qualified Prometheus (Label4) - import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone) +import System.Clock (getTime, Clock(Monotonic), TimeSpec) +import GHC.Conc (unsafeIOToSTM) -data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } - | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } - | JobQueueNotification { jNotification :: Notification } - | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId - , jRequestTime :: UTCTime - , jSubject :: Maybe Text - , jHelpRequest :: Maybe Html - , jReferer :: Maybe Text - , jError :: Maybe ErrorResponse - } - | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } - | JobDistributeCorrections { jSheet :: SheetId } - | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId - , jAllRecipientAddresses :: Set Address - , jCourse :: CourseId - , jSender :: UserId - , jMailObjectUUID :: UUID - , jSubject :: Maybe Text - , jMailContent :: Html - } - | JobInvitation { jInviter :: Maybe UserId - , jInvitee :: UserEmail - , jInvitationUrl :: Text - , jInvitationSubject :: Text - , jInvitationExplanation :: Html + +data Job + = JobSendNotification { jRecipient :: UserId, jNotification :: Notification } + | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext } + | JobQueueNotification { jNotification :: Notification } + | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId + , jRequestTime :: UTCTime + , jSubject :: Maybe Text + , jHelpRequest :: Maybe Html + , jReferer :: Maybe Text + , jError :: Maybe ErrorResponse + } + | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings } + | JobDistributeCorrections { jSheet :: SheetId } + | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId + , jAllRecipientAddresses :: Set Address + , jCourse :: CourseId + , jSender :: UserId + , jMailObjectUUID :: UUID + , jSubject :: Maybe Text + , jMailContent :: Html + } + | JobInvitation { jInviter :: Maybe UserId + , jInvitee :: UserEmail + , jInvitationUrl :: Text + , jInvitationSubject :: Text + , jInvitationExplanation :: Html + } + | JobSendPasswordReset { jRecipient :: UserId } - | JobSendPasswordReset { jRecipient :: UserId - } - | JobTruncateTransactionLog - | JobPruneInvitations - | JobDeleteTransactionLogIPs - | JobSynchroniseLdap { jNumIterations + | JobTruncateTransactionLog + | JobPruneInvitations + | JobDeleteTransactionLogIPs + | JobSynchroniseLdap { jNumIterations + , jEpoch + , jIteration :: Natural + } + | JobSynchroniseLdapUser { jUser :: UserId + } + | JobChangeUserDisplayEmail { jUser :: UserId + , jDisplayEmail :: UserEmail + } + | JobPruneSessionFiles + | JobPruneUnreferencedFiles { jNumIterations , jEpoch , jIteration :: Natural } - | JobSynchroniseLdapUser { jUser :: UserId - } - | JobChangeUserDisplayEmail { jUser :: UserId - , jDisplayEmail :: UserEmail - } - | JobPruneSessionFiles - | JobPruneUnreferencedFiles { jNumIterations - , jEpoch - , jIteration :: Natural - } - | JobInjectFiles - | JobPruneFallbackPersonalisedSheetFilesKeys - | JobRechunkFiles + | JobInjectFiles + | JobPruneFallbackPersonalisedSheetFilesKeys + | JobRechunkFiles + | JobDetectMissingFiles deriving (Eq, Ord, Show, Read, Generic, Typeable) -data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } - | NotificationSheetActive { nSheet :: SheetId } - | NotificationSheetSoonInactive { nSheet :: SheetId } - | NotificationSheetInactive { nSheet :: SheetId } - | NotificationSheetHint { nSheet :: SheetId } - | NotificationSheetSolution { nSheet :: SheetId } - | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } - | NotificationCorrectionsNotDistributed { nSheet :: SheetId } - | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } - | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } - | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } - | NotificationExamRegistrationActive { nExam :: ExamId } - | NotificationExamRegistrationSoonInactive { nExam :: ExamId } - | NotificationExamDeregistrationSoonInactive { nExam :: ExamId } - | NotificationExamResult { nExam :: ExamId } - | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId } - | NotificationAllocationRegister { nAllocations :: Set AllocationId } - | NotificationAllocationAllocation { nAllocations :: Set AllocationId } - | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId } - | NotificationExamOfficeExamResults { nExam :: ExamId } - | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId } - | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId } - | NotificationAllocationResults { nAllocation :: AllocationId } - | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId } - | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId } - | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } - | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } +data Notification + = NotificationSubmissionRated { nSubmission :: SubmissionId } + | NotificationSheetActive { nSheet :: SheetId } + | NotificationSheetSoonInactive { nSheet :: SheetId } + | NotificationSheetInactive { nSheet :: SheetId } + | NotificationSheetHint { nSheet :: SheetId } + | NotificationSheetSolution { nSheet :: SheetId } + | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId } + | NotificationCorrectionsNotDistributed { nSheet :: SheetId } + | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } + | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } + | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } + | NotificationExamRegistrationActive { nExam :: ExamId } + | NotificationExamRegistrationSoonInactive { nExam :: ExamId } + | NotificationExamDeregistrationSoonInactive { nExam :: ExamId } + | NotificationExamResult { nExam :: ExamId } + | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId } + | NotificationAllocationRegister { nAllocations :: Set AllocationId } + | NotificationAllocationAllocation { nAllocations :: Set AllocationId } + | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId } + | NotificationAllocationNewCourse { nAllocation :: AllocationId, nCourse :: CourseId } + | NotificationExamOfficeExamResults { nExam :: ExamId } + | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId } + | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId } + | NotificationAllocationResults { nAllocation :: AllocationId } + | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId } + | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId } + | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId } + | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job @@ -155,8 +157,11 @@ data JobCtl = JobCtlFlush | JobCtlQueue Job | JobCtlGenerateHealthReport HealthCheck | JobCtlTest + | JobCtlSleep Micro -- | For debugging deriving (Eq, Ord, Read, Show, Generic, Typeable) +makePrisms ''JobCtl + instance Hashable JobCtl instance NFData JobCtl @@ -179,7 +184,8 @@ type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJo data JobHandler site = JobHandlerAtomic (YesodJobDB site ()) | JobHandlerException (HandlerFor site ()) - deriving (Generic, Typeable) + | forall a. JobHandlerAtomicWithFinalizer (YesodJobDB site a) (a -> HandlerFor site ()) + deriving (Typeable) makePrisms ''JobHandler @@ -199,20 +205,6 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "state" "data" } ''JobWorkerState -classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4 -classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob) - where - Aeson.Object obj = Aeson.toJSON jws - Aeson.String tag = obj HashMap.! "state" - mJobCtl = asum - [ classifyJobCtl <$> jws ^? _jobWorkerJobCtl - , "perform" <$ jws ^? _jobWorkerJob - ] - mJob = classifyJob <$> jws ^? _jobWorkerJob - -withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a -withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt - newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique } deriving (Eq, Ord) @@ -258,20 +250,38 @@ jobNoQueueSame = \case JobInjectFiles{} -> True JobPruneFallbackPersonalisedSheetFilesKeys{} -> True JobRechunkFiles{} -> True + JobDetectMissingFiles{} -> True _ -> False +jobMovable :: JobCtl -> Bool +jobMovable = isn't _JobCtlTest -newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue JobPriority JobCtl } + +newtype JobQueue = JobQueue { getJobQueue :: MaxPQueue (JobPriority, Down TimeSpec) JobCtl } deriving (Eq, Ord, Read, Show) deriving newtype (Semigroup, Monoid, NFData) makePrisms ''JobQueue -jqInsert :: JobCtl -> JobQueue -> JobQueue -jqInsert job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job) job +jqInsert' :: TimeSpec -> JobCtl -> JobQueue -> JobQueue +jqInsert' cTime job = force . over _JobQueue $ PQ.insertBehind (prioritiseJob job, Down cTime) job + +jqInsert :: JobCtl -> JobQueue -> STM JobQueue +jqInsert job queue = do + cTime <- unsafeIOToSTM $ getTime Monotonic + return $ jqInsert' cTime job queue + +jqDequeue' :: JobQueue -> Maybe (((JobPriority, Down TimeSpec), JobCtl), JobQueue) +jqDequeue' = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxViewWithKey . getJobQueue jqDequeue :: JobQueue -> Maybe (JobCtl, JobQueue) -jqDequeue = fmap ((\r@(_, q) -> q `deepseq` r) . over _2 JobQueue) . PQ.maxView . getJobQueue +jqDequeue = fmap (over _1 $ view _2) . jqDequeue' + +jqDepth :: Integral n => JobQueue -> n +jqDepth = fromIntegral . PQ.size . getJobQueue + +jqContents :: IndexedTraversal' (JobPriority, Down TimeSpec) JobQueue JobCtl +jqContents = _JobQueue . PQ.traverseWithKey . indexed data JobState = JobState @@ -286,3 +296,5 @@ data JobState = JobState jobWorkerNames :: JobState -> Set JobWorkerId jobWorkerNames JobState{..} = Set.map jobWorkerName $ Map.keysSet jobWorkers + +makeLenses_ ''JobState diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 0d77f6da3..27657bbe5 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -45,6 +45,10 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize)) +import Data.Time.Format.ISO8601 (iso8601Show) + +import qualified Data.Time.Zones as TZ + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -166,7 +170,21 @@ migrateManual = do , ("submission_sheet", "CREATE INDEX submission_sheet ON submission (sheet)" ) , ("submission_edit_submission", "CREATE INDEX submission_edit_submission ON submission_edit (submission)" ) , ("user_ldap_primary_key", "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)" ) + , ("file_content_entry_chunk_hash", "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)" ) ] + + recordedChangelogItems <- lift . lift $ selectList [] [] + let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems' + where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ] + unless (null missingChangelogItems) $ do + now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime + addMigration False $ + let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|] + vals = Text.intercalate ", " $ do + item <- missingChangelogItems + return [st|('#{toPathPiece item}', '#{now}')|] + in sql + where addIndex :: Text -> Sql -> Migration addIndex ixName ixDef = do @@ -945,10 +963,30 @@ customMigrations = Map.fromListWith (>>) 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 (hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL); + 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); |] ) + , ( AppliedMigrationKey [migrationVersion|41.0.0|] [version|42.0.0|] + , 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}; + |] + ) + , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|] + , unlessM (tableExists "changelog_item_first_seen") $ do + [executeQQ| + CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL); + |] + insertMany_ [ ChangelogItemFirstSeen{..} + | (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays + ] + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b40e5c912..a8e437f17 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -17,3 +17,4 @@ import Model.Types.Allocation as Types import Model.Types.Languages as Types import Model.Types.File as Types import Model.Types.User as Types +import Model.Types.Changelog as Types diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs new file mode 100644 index 000000000..37d9828d5 --- /dev/null +++ b/src/Model/Types/Changelog.hs @@ -0,0 +1,145 @@ +module Model.Types.Changelog + ( ChangelogItem(..) + , changelogItemMap + , ChangelogItemKind(..), _ChangelogItemFeature, _ChangelogItemBugfix + , classifyChangelogItem + , changelogItemDays + ) where + +import Import.NoModel + +import Model.Types.TH.PathPiece + +import qualified Data.Map as Map + + +mkI18nWidgetEnum "Changelog" "changelog" +derivePersistFieldPathPiece ''ChangelogItem +pathPieceJSONKey ''ChangelogItem +pathPieceJSON ''ChangelogItem +pathPieceHttpApiData ''ChangelogItem + +data ChangelogItemKind + = ChangelogItemFeature + | ChangelogItemBugfix + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +makePrisms ''ChangelogItemKind + +classifyChangelogItem :: ChangelogItem -> ChangelogItemKind +classifyChangelogItem = \case + ChangelogHaskellCampusLogin -> ChangelogItemBugfix + ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix + ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix + ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix + ChangelogPassingByPointsWorks -> ChangelogItemBugfix + ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix + ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix + ChangelogFormsTimesReset -> ChangelogItemBugfix + _other -> ChangelogItemFeature + +changelogItemDays :: Map ChangelogItem Day +changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2) + [ (ChangelogConfigurableDatetimeFormat, [day|2018-07-10|]) + , (ChangelogCourseListOverAllTerms, [day|2018-07-31|]) + , (ChangelogCorrectionsDisplayImprovements, [day|2018-07-31|]) + , (ChangelogHaskellCampusLogin, [day|2018-08-01|]) + , (ChangelogFileDownloadOption, [day|2018-08-06|]) + , (ChangelogSheetsNoSubmissionAndZipControl, [day|2018-09-18|]) + , (ChangelogSmartCorrectionDistribution, [day|2018-09-18|]) + , (ChangelogTableSummaries, [day|2018-09-18|]) + , (ChangelogPersonalInformation, [day|2018-09-18|]) + , (ChangelogCourseShorthandsWithinSchools, [day|2018-09-18|]) + , (ChangelogTooltipsWithoutJavascript, [day|2018-09-18|]) + , (ChangelogEmailNotifications, [day|2018-10-19|]) + , (ChangelogSupportWidget, [day|2018-10-19|]) + , (ChangelogAccountDeletionDuringTesting, [day|2018-10-19|]) + , (ChangelogImprovementsForCorrectors, [day|2018-11-09|]) + , (ChangelogButtonsWorkWithoutJavascript, [day|2018-11-09|]) + , (ChangelogTableFormsWorkAfterAjax, [day|2018-11-29|]) + , (ChangelogPassingByPointsWorks, [day|2018-11-30|]) + , (ChangelogErrorMessagesForTableItemVanish, [day|2019-01-16|]) + , (ChangelogAssignedCorrectionsFilters, [day|2019-01-16|]) + , (ChangelogCourseConvenienceLinks, [day|2019-01-16|]) + , (ChangelogAsidenav, [day|2019-01-30|]) + , (ChangelogCourseAssociatedStudyField, [day|2019-03-20|]) + , (ChangelogStudyFeatures, [day|2019-03-27|]) + , (ChangelogCourseAdministratorRoles, [day|2019-03-27|]) + , (ChangelogCourseAdministratorInvitations, [day|2019-04-20|]) + , (ChangelogCourseMessages, [day|2019-04-20|]) + , (ChangelogCorrectorsOnCourseShow, [day|2019-04-29|]) + , (ChangelogTutorials, [day|2019-04-29|]) + , (ChangelogCourseMaterials, [day|2019-05-04|]) + , (ChangelogDownloadAllSheetFiles, [day|2019-05-10|]) + , (ChangelogImprovedSubmittorUi, [day|2019-05-10|]) + , (ChangelogCourseRegisterByAdmin, [day|2019-05-13|]) + , (ChangelogReworkedAutomaticCorrectionDistribution, [day|2019-05-20|]) + , (ChangelogDownloadAllSheetFilesByType, [day|2019-06-07|]) + , (ChangelogSheetSpecificFiles, [day|2019-06-07|]) + , (ChangelogExams, [day|2019-06-26|]) + , (ChangelogCsvExamParticipants, [day|2019-07-23|]) + , (ChangelogAllocationCourseRegistration, [day|2019-08-12|]) + , (ChangelogAllocationApplications, [day|2019-08-19|]) + , (ChangelogCsvCourseApplications, [day|2019-08-27|]) + , (ChangelogAllocationsNotifications, [day|2019-09-05|]) + , (ChangelogConfigurableDisplayEmails, [day|2019-09-12|]) + , (ChangelogConfigurableDisplayNames, [day|2019-09-12|]) + , (ChangelogEstimateAllocatedCourseCapacity, [day|2019-09-12|]) + , (ChangelogNotificationExamRegistration, [day|2019-09-13|]) + , (ChangelogExamClosure, [day|2019-09-16|]) + , (ChangelogExamOfficeExamNotification, [day|2019-09-16|]) + , (ChangelogExamOffices, [day|2019-09-16|]) + , (ChangelogExamAchievementParticipantDuplication, [day|2019-09-25|]) + , (ChangelogFormsTimesReset, [day|2019-09-25|]) + , (ChangelogExamAutomaticResults, [day|2019-09-25|]) + , (ChangelogExamAutomaticBoni, [day|2019-09-25|]) + , (ChangelogAutomaticallyAcceptCourseApplications, [day|2019-09-27|]) + , (ChangelogCourseNews, [day|2019-10-01|]) + , (ChangelogCsvExportCourseParticipants, [day|2019-10-08|]) + , (ChangelogNotificationCourseParticipantViaAdmin, [day|2019-10-08|]) + , (ChangelogCsvExportCourseParticipantsFeatures, [day|2019-10-09|]) + , (ChangelogCourseOccurences, [day|2019-10-09|]) + , (ChangelogTutorialRegistrationViaParticipantTable, [day|2019-10-10|]) + , (ChangelogCsvExportCourseParticipantsRegisteredTutorials, [day|2019-10-10|]) + , (ChangelogCourseParticipantsSex, [day|2019-10-14|]) + , (ChangelogTutorialTutorControl, [day|2019-10-14|]) + , (ChangelogCsvOptionCharacterSet, [day|2019-10-23|]) + , (ChangelogCsvOptionTimestamp, [day|2019-10-23|]) + , (ChangelogEnglish, [day|2019-10-31|]) + , (ChangelogI18n, [day|2019-10-31|]) + , (ChangelogLmuInternalFields, [day|2019-11-28|]) + , (ChangelogNotificationSubmissionChanged, [day|2019-12-05|]) + , (ChangelogExportCourseParticipants, [day|2020-01-17|]) + , (ChangelogExternalExams, [day|2020-01-17|]) + , (ChangelogExamAutomaticRoomDistribution, [day|2020-01-29|]) + , (ChangelogWarningMultipleSemesters, [day|2020-01-30|]) + , (ChangelogExamAutomaticRoomDistributionBetterRulesDisplay, [day|2020-01-30|]) + , (ChangelogReworkedNavigation, [day|2020-02-07|]) + , (ChangelogExamCorrect, [day|2020-02-08|]) + , (ChangelogExamGradingMode, [day|2020-02-19|]) + , (ChangelogMarkdownEmails, [day|2020-02-23|]) + , (ChangelogMarkdownHtmlInput, [day|2020-02-23|]) + , (ChangelogBetterCsvImport, [day|2020-03-06|]) + , (ChangelogAdditionalDatetimeFormats, [day|2020-03-16|]) + , (ChangelogServerSideSessions, [day|2020-03-16|]) + , (ChangelogWebinterfaceAllocationAllocation, [day|2020-03-16|]) + , (ChangelogBetterTableCellColourCoding, [day|2020-03-16|]) + , (ChangelogCourseOccurrenceNotes, [day|2020-03-31|]) + , (ChangelogHideSystemMessages, [day|2020-04-15|]) + , (ChangelogNonAnonymisedCorrection, [day|2020-04-17|]) + , (ChangelogBetterCourseParticipantDetailPage, [day|2020-04-17|]) + , (ChangelogFaq, [day|2020-04-24|]) + , (ChangelogRegisteredSubmissionGroups, [day|2020-04-28|]) + , (ChangelogFormerCourseParticipants, [day|2020-05-05|]) + , (ChangelogBetterFileUploads, [day|2020-05-05|]) + , (ChangelogSheetPassAlways, [day|2020-05-23|]) + , (ChangelogBetterCourseCommunicationTutorials, [day|2020-05-25|]) + , (ChangelogAdditionalSheetNotifications, [day|2020-05-25|]) + , (ChangelogCourseParticipantsListAddSheets, [day|2020-06-14|]) + , (ChangelogYamlRatings, [day|2020-06-17|]) + , (ChangelogSubmissionOnlyExamRegistered, [day|2020-07-20|]) + , (ChangelogCourseVisibility, [day|2020-08-10|]) + , (ChangelogPersonalisedSheetFiles, [day|2020-08-10|]) + , (ChangelogAbolishCourseAssociatedStudyFeatures, [day|2020-08-28|]) + ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 6dbc7122e..6938ef227 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -32,6 +32,12 @@ module Model.Types.Exam , hasExamGradingPass, hasExamGradingGrades , ExamPartNumber , _ExamPartNumber, _ExamPartNumber' + , ExamAids(..), ExamAidsPreset(..) + , ExamOnline(..), ExamOnlinePreset(..) + , ExamSynchronicity(..), ExamSynchronicityPreset(..) + , ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..) + , ExamMode(..) + , ExamModePredicate(..), ExamModeDNF(..) ) where import Import.NoModel @@ -59,6 +65,8 @@ import qualified Data.Foldable import Data.Aeson (genericToJSON, genericParseJSON) +import Model.Types.Security + {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} @@ -427,3 +435,125 @@ pathPieceJSONKey ''ExamPartNumber instance Enum ExamPartNumber where toEnum = review _ExamPartNumber' . toEnum fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber' + + +data ExamAids + = ExamAidsPreset { examAidsPreset :: ExamAidsPreset } + | ExamAidsCustom { examAidsCustom :: Html } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data ExamAidsPreset + = ExamOpenBook + | ExamClosedBook + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "mode" "data" + } ''ExamAids +derivePersistFieldJSON ''ExamAids + +nullaryPathPiece' ''ExamAidsPreset $ nameToPathPiece' 1 +pathPieceJSON ''ExamAidsPreset + +data ExamOnline + = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset } + | ExamOnlineCustom { examOnlineCustom :: Html } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data ExamOnlinePreset + = ExamOnline + | ExamOffline + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "mode" "data" + } ''ExamOnline +derivePersistFieldJSON ''ExamOnline + +nullaryPathPiece' ''ExamOnlinePreset $ nameToPathPiece' 1 +pathPieceJSON ''ExamOnlinePreset + +data ExamSynchronicity + = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset } + | ExamSynchronicityCustom { examSynchronicityCustom :: Html } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data ExamSynchronicityPreset + = ExamSynchronous + | ExamAsynchronous + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "mode" "data" + } ''ExamSynchronicity +derivePersistFieldJSON ''ExamSynchronicity + +nullaryPathPiece' ''ExamSynchronicityPreset $ nameToPathPiece' 1 +pathPieceJSON ''ExamSynchronicityPreset + +data ExamRequiredEquipment + = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset } + | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +data ExamRequiredEquipmentPreset + = ExamRequiredEquipmentNone + | ExamRequiredEquipmentPen + | ExamRequiredEquipmentPaperPen + | ExamRequiredEquipmentCalculatorPen + | ExamRequiredEquipmentCalculatorPaperPen + | ExamRequiredEquipmentWebcamMicrophoneInternet + | ExamRequiredEquipmentMicrophoneInternet + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "mode" "data" + } ''ExamRequiredEquipment +derivePersistFieldJSON ''ExamRequiredEquipment + +nullaryPathPiece' ''ExamRequiredEquipmentPreset $ nameToPathPiece' 3 +pathPieceJSON ''ExamRequiredEquipmentPreset + + +data ExamMode = ExamMode + { examAids :: Maybe ExamAids + , examOnline :: Maybe ExamOnline + , examSynchronicity :: Maybe ExamSynchronicity + , examRequiredEquipment :: Maybe ExamRequiredEquipment + } +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = UntaggedValue + } ''ExamMode +derivePersistFieldJSON ''ExamMode + +data ExamModePredicate + = ExamModePredAids ExamAidsPreset + | ExamModePredOnline ExamOnlinePreset + | ExamModePredSynchronicity ExamSynchronicityPreset + | ExamModePredRequiredEquipment ExamRequiredEquipmentPreset + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + , sumEncoding = TaggedObject "setting" "preset" + } ''ExamModePredicate +derivePathPiece ''ExamModePredicate (camelToPathPiece' 3) "--" +deriveFinite ''ExamModePredicate + +newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece) + +derivePersistFieldJSON ''ExamModeDNF diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index cbb7af356..dca966dd4 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -43,6 +43,7 @@ data NotificationTrigger | NTAllocationStaffRegister | NTAllocationAllocation | NTAllocationRegister + | NTAllocationNewCourse | NTAllocationOutdatedRatings | NTAllocationUnratedApplications | NTAllocationResults @@ -72,6 +73,7 @@ instance Default NotificationSettings where defaultOff = HashSet.fromList [ NTSheetSoonInactive , NTExamRegistrationSoonInactive + , NTAllocationNewCourse ] instance ToJSON NotificationSettings where diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 9df7be8ab..f984a38d9 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -184,6 +184,9 @@ dnfAssumeValue var val disagrees PLNegated{..} = plVar == var && val disagrees PLVariable{..} = plVar == var && not val +predDNFFalse :: PredDNF a +predDNFFalse = PredDNF Set.empty + data UserGroupName = UserGroupMetrics diff --git a/src/Settings.hs b/src/Settings.hs index acedff5c4..4e40ba9a4 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -12,6 +12,7 @@ module Settings , module Settings.Mime , module Settings.Cookies , module Settings.Log + , module Settings.Locale ) where import Import.NoModel @@ -55,6 +56,7 @@ import Settings.Cluster import Settings.Mime import Settings.Cookies import Settings.Log +import Settings.Locale import qualified System.FilePath as FilePath @@ -117,6 +119,7 @@ data AppSettings = AppSettings , appJobFlushInterval :: Maybe NominalDiffTime , appJobCronInterval :: Maybe NominalDiffTime , appJobStaleThreshold :: NominalDiffTime + , appJobMoveThreshold :: Maybe DiffTime , appNotificationRateLimit :: NominalDiffTime , appNotificationCollateDelay :: NominalDiffTime , appNotificationExpiration :: NominalDiffTime @@ -454,6 +457,7 @@ instance FromJSON AppSettings where appJobFlushInterval <- o .:? "job-flush-interval" appJobCronInterval <- o .:? "job-cron-interval" appJobStaleThreshold <- o .: "job-stale-threshold" + appJobMoveThreshold <- o .:? "job-move-threshold" appNotificationRateLimit <- o .: "notification-rate-limit" appNotificationCollateDelay <- o .: "notification-collate-delay" appNotificationExpiration <- o .: "notification-expiration" @@ -603,10 +607,3 @@ compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of Aeson.Error e -> error e Aeson.Success settings -> settings - - -getTimeLocale' :: [Lang] -> TimeLocale -getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) - -appTZ :: TZ -appTZ = $(includeSystemTZ "Europe/Berlin") diff --git a/src/Settings/Locale.hs b/src/Settings/Locale.hs new file mode 100644 index 000000000..f3d0f7a40 --- /dev/null +++ b/src/Settings/Locale.hs @@ -0,0 +1,21 @@ +module Settings.Locale + ( getTimeLocale' + , appTZ + , appLanguages + ) where + +import Utils.DateTime + +import Data.List.NonEmpty + +import Text.Shakespeare.I18N (Lang) + + +getTimeLocale' :: [Lang] -> TimeLocale +getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")]) + +appTZ :: TZ +appTZ = $(includeSystemTZ "Europe/Berlin") + +appLanguages :: NonEmpty Lang +appLanguages = "de-de-formal" :| ["en-eu"] diff --git a/src/System/Clock/Instances.hs b/src/System/Clock/Instances.hs index 16082a700..936d6ea38 100644 --- a/src/System/Clock/Instances.hs +++ b/src/System/Clock/Instances.hs @@ -8,6 +8,35 @@ import ClassyPrelude import System.Clock import Data.Ratio ((%)) +import Data.Fixed + +import Control.Lens + instance Real TimeSpec where toRational TimeSpec{..} = fromIntegral sec + fromIntegral nsec % 1e9 + +instance Fractional TimeSpec where + a / b = fromRational $ toRational a / toRational b + fromRational n = fromNanoSecs n' + where MkFixed n' = fromRational n :: Nano + +instance RealFrac TimeSpec where + properFraction = over _2 fromRational . properFraction . toRational + + round x = let (n,r) = properFraction x + m = bool (n + 1) (n -1) $ r < fromRational 0 + s = signum (abs r - fromRational 0.5) + in if | s == fromRational (-1) -> n + | s == fromRational 0 -> bool m n $ even n + | s == fromRational 1 -> m + | otherwise -> error "round @TimeSpec: Bad value" + + ceiling x = bool n (n + 1) $ r > 0 + where (n,r) = properFraction x + + floor x = bool n (n - 1) $ r > 0 + where (n,r) = properFraction x + +instance NFData TimeSpec +instance Hashable TimeSpec diff --git a/src/UnliftIO/Async/Utils.hs b/src/UnliftIO/Async/Utils.hs index 3e0184997..851a72367 100644 --- a/src/UnliftIO/Async/Utils.hs +++ b/src/UnliftIO/Async/Utils.hs @@ -4,35 +4,66 @@ module UnliftIO.Async.Utils , allocateAsyncMasked, allocateLinkedAsyncMasked ) where -import ClassyPrelude hiding (cancel, async, link) +import ClassyPrelude hiding (cancel, async, link, finally, mask) import Control.Lens +import Control.Lens.Extras (is) import qualified UnliftIO.Async as UnliftIO import qualified Control.Concurrent.Async as A import Control.Monad.Trans.Resource +import qualified Control.Monad.Trans.Resource.Internal as ResourceT.Internal +import Data.Acquire + +import Control.Monad.Catch + + +withReference :: forall m a. (MonadUnliftIO m, MonadResource m) => ((IO (), IO ()) -> m a) -> m a +withReference act = do + releaseAct <- newEmptyTMVarIO + + let doAlloc = do + iSt <- liftResourceT getInternalState + liftIO $ mask $ \_ -> do + ResourceT.Internal.stateAlloc iSt + atomically $ putTMVar releaseAct () + return iSt + doRelease iSt eCase = liftIO . whenM (atomically $ is _Just <$> tryTakeTMVar releaseAct) $ do + flip ResourceT.Internal.stateCleanup iSt $ case eCase of + ExitCaseSuccess _ -> ReleaseNormal + ExitCaseException _ -> ReleaseException + ExitCaseAbort -> ReleaseEarly + + withRunInIO $ \run -> + fmap fst . generalBracket (run doAlloc) doRelease $ \iSt -> do + res <- run $ act + ( atomically $ takeTMVar releaseAct + , ResourceT.Internal.stateCleanup ReleaseNormal iSt + ) + atomically $ guard =<< isEmptyTMVar releaseAct + return res allocateAsync :: forall m a. ( MonadUnliftIO m, MonadResource m ) => m a -> m (Async a) -allocateAsync act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel . A.async $ run act +allocateAsync act = withReference $ \(signalReady, releaseRef) -> withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel . A.async . flip finally releaseRef $ signalReady >> run act allocateLinkedAsync :: forall m a. (MonadUnliftIO m, MonadResource m) => m a -> m (Async a) allocateLinkedAsync = uncurry (<$) . (id &&& UnliftIO.link) <=< allocateAsync allocateAsyncWithUnmask :: forall m a. - ( MonadUnliftIO m, MonadResource m ) + ( MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a) -allocateAsyncWithUnmask act = withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel $ A.asyncWithUnmask $ \unmask -> run $ act (liftIO . unmask . run) +allocateAsyncWithUnmask act = withReference $ \(signalReady, releaseRef) -> withRunInIO $ \run -> run . fmap (view _2) . flip allocate A.cancel $ A.asyncWithUnmask $ \unmask -> flip finally releaseRef $ signalReady >> run (act $ liftIO . unmask . run) allocateLinkedAsyncWithUnmask :: forall m a. (MonadUnliftIO m, MonadResource m) => ((forall b. m b -> m b) -> m a) -> m (Async a) allocateLinkedAsyncWithUnmask act = uncurry (<$) . (id &&& UnliftIO.link) =<< allocateAsyncWithUnmask act allocateAsyncMasked :: forall m a. - ( MonadUnliftIO m, MonadResource m ) + ( MonadUnliftIO m, MonadResource m) => m a -> m (Async a) allocateAsyncMasked act = allocateAsyncWithUnmask (const act) diff --git a/src/Utils.hs b/src/Utils.hs index 5f25e1ac3..966f0e27c 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -3,7 +3,7 @@ module Utils , List.nub, List.nubBy ) where -import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch) +import ClassyPrelude.Yesod hiding (foldlM, Proxy, handle, catch, bracket) -- import Data.Double.Conversion.Text -- faster implementation for textPercent? import qualified Data.Foldable as Fold @@ -31,6 +31,7 @@ import Utils.Cookies as Utils import Utils.Cookies.Registered as Utils import Utils.Session as Utils import Utils.Csv as Utils +import Utils.NTop as Utils import Text.Blaze (Markup, ToMarkup) @@ -106,17 +107,24 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded import Data.Constraint (Dict(..)) -import Control.Monad.Random.Class (MonadRandom) +import Control.Monad.Random.Class (MonadSplit(getSplit), MonadRandom, MonadInterleave(interleave), uniform) +import Control.Monad.Random (RandomGen) import qualified System.Random.Shuffle as Rand (shuffleM) +import qualified Control.Monad.Random.Lazy as LazyRand import Data.Data (Data) import qualified Data.Text.Lazy.Builder as Builder -import Unsafe.Coerce +import Data.Coerce import System.FilePath as Utils (addExtension, isExtensionOf) import System.FilePath (dropDrive) +import Yesod.Core.Types +import Yesod.Core.Types.Instances.Catch () +import Control.Monad.Trans.Resource +import Control.Monad.Reader.Class (MonadReader(local)) + {-# ANN module ("HLint: ignore Use asum" :: String) #-} @@ -187,6 +195,19 @@ instance HasContentType YamlValue where toYAML :: ToJSON a => a -> YamlValue toYAML = YamlValue . toJSON + +delimitInternalState :: forall site a. HandlerFor site a -> HandlerFor site a +-- | Switches the `InternalState` contained within the environment of `HandlerFor` to new one created with `bracket` +-- +-- Therefor all `ResourceT`-Resources allocated within the inner `HandlerFor`-Action are collected at the end of it. +delimitInternalState act = bracket createInternalState closeInternalState $ \newInternalState -> local (renewEnviron newInternalState) act + where + renewEnviron newInternalState HandlerData{..} + = HandlerData { handlerResource = newInternalState + , .. + } + + --------------------- -- Text and String -- --------------------- @@ -278,6 +299,19 @@ textBytes x rshow :: Double -> Text rshow = tshow . floorToDigits 1 +textDuration :: forall a. Integral a => a -> Text +textDuration n' = view _2 $ foldr acc (toInteger n', "") units + where units = sortOn (view _1) + [ (86400, "d") + , (3600, "h") + , (60, "m") + , (1, "s") + ] + acc (mult, unit) (n, t) + | unitCount > 0 = (unitRem, t <> tshow unitCount <> unit) + | otherwise = (n, t) + where (unitCount, unitRem) = n `divMod` mult + stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes stepTextCounterCI = CI.map stepTextCounter @@ -621,16 +655,7 @@ ignoreNothing _ Nothing y = y ignoreNothing _ x Nothing = x ignoreNothing f (Just x) (Just y) = Just $ f x y -newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom - -instance Eq a => Eq (NTop (Maybe a)) where - (NTop x) == (NTop y) = x == y - -instance Ord a => Ord (NTop (Maybe a)) where - compare (NTop Nothing) (NTop Nothing) = EQ - compare (NTop Nothing) _ = GT - compare _ (NTop Nothing) = LT - compare (NTop (Just x)) (NTop (Just y)) = compare x y +-- `NTop` moved to `Utils.NTop` exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT @@ -721,6 +746,9 @@ throwExceptT :: ( Exception e, MonadThrow m ) => ExceptT e m a -> m a throwExceptT = exceptT throwM return +generalFinally :: MonadMask m => m a -> (ExitCase a -> m b) -> m a +generalFinally action finalizer = view _1 <$> generalBracket (return ()) (const finalizer) (const action) + ------------ -- Monads -- ------------ @@ -1174,6 +1202,10 @@ unstableSortOn = unstableSortBy . comparing unstableSort :: (MonadRandom m, Ord a) => [a] -> m [a] unstableSort = unstableSortBy compare +uniforms :: (RandomGen g, MonadSplit g m, Foldable t) => t a -> m [a] +uniforms xs = LazyRand.evalRand go <$> getSplit + where go = (:) <$> interleave (uniform xs) <*> go + ---------- -- Lens -- ---------- @@ -1218,8 +1250,8 @@ instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where mempty = MergeHashMap HashMap.empty instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where parseJSON = case Aeson.fromJSONKey of - Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $ - uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson.> Aeson.Key k) + Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $ + coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.> Aeson.Key k) . HashMap.toList Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $ fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.> Aeson.Key k <*> m) (pure mempty) Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $ @@ -1227,9 +1259,6 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr -> fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr where - uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v) - uc = unsafeCoerce - parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b) parseIndexedJSONPair keyParser valParser idx value = p value Aeson.> Aeson.Index idx where @@ -1244,6 +1273,61 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.> Aeson.Index idx + +newtype MergeMap k v = MergeMap { unMergeMap :: Map k v } + deriving (Show, Generic, Typeable, Data) + deriving newtype ( Eq, Ord + , Functor, Foldable, NFData + , ToJSON + ) + +makePrisms ''MergeMap +makeWrapped ''MergeMap + +type instance Element (MergeMap k v) = v + +instance MonoFoldable (MergeMap k v) +instance MonoFunctor (MergeMap k v) +instance MonoTraversable (MergeMap k v) + +instance Traversable (MergeMap k) where + traverse = _MergeMap . traverse + +instance FunctorWithIndex k (MergeMap k) +instance TraversableWithIndex k (MergeMap k) where + itraverse = _MergeMap .> itraverse +instance FoldableWithIndex k (MergeMap k) + +instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where + (MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b +instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where + mempty = MergeMap Map.empty +instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where + parseJSON = case Aeson.fromJSONKey of + Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $ + coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.> Aeson.Key k) . HashMap.toList + Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $ + fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson.> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList + Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $ + fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson.> Aeson.Key k <*> parseJSON v Aeson.> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList + Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr -> + fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr + where + parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b) + parseIndexedJSONPair keyParser valParser idx value = p value Aeson.> Aeson.Index idx + where + p = Aeson.withArray "(k, v)" $ \ab -> + let n = V.length ab + in if n == 2 + then (,) <$> parseJSONElemAtIndex keyParser 0 ab + <*> parseJSONElemAtIndex valParser 1 ab + else fail $ "cannot unpack array of length " ++ + show n ++ " into a pair" + + parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a + parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.> Aeson.Index idx + + -------------- -- FilePath -- -------------- @@ -1255,3 +1339,10 @@ infixr 4 /> (/>) :: FilePath -> FilePath -> FilePath dir /> file = dir > dropDrive file + + +---------------- +-- TH Dungeon -- +---------------- + +makePrisms ''ExitCase diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 27b30c9bf..0ef6ca5a0 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -12,6 +12,7 @@ module Utils.DateTime , nominalHour, nominalMinute , minNominalYear, avgNominalYear , module Zones + , day ) where import ClassyPrelude.Yesod hiding (lift) @@ -23,12 +24,14 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ) import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime) import Data.Time.Format (FormatTime) import Data.Time.Clock.System (systemEpochDay) +import qualified Data.Time.Format.ISO8601 as Time import qualified Data.Time.Format as Time import qualified Data.List.NonEmpty as NonEmpty import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) import Instances.TH.Lift () import Data.Data (Data) @@ -45,6 +48,8 @@ import Algebra.Lattice.Ordered import Control.Monad.Fail +import Utils.Lang (selectLanguage') + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -142,3 +147,15 @@ nominalMinute = 60 minNominalYear, avgNominalYear :: NominalDiffTime minNominalYear = 365 * nominalDay avgNominalYear = fromRational $ 365.2425 * toRational nominalDay + +--------- +-- Day -- +--------- + +day :: QuasiQuoter +day = QuasiQuoter{..} + where + quotePat = error "day used as pattern" + quoteType = error "day used as type" + quoteDec = error "day used as declaration" + quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 3119313da..3b334391c 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -7,6 +7,7 @@ module Utils.Files ) where import Import.NoFoundation +import Utils.Metrics import Foundation.Type import Handler.Utils.Minio import qualified Network.Minio as Minio @@ -46,6 +47,8 @@ sinkFileDB doReplace fileContentContent = do fileChunkLockTime <- liftIO getCurrentTime fileChunkLockInstance <- getsYesod appInstanceID + observeSunkChunk StorageDB $ olength fileContentChunkContent + tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. } existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash] let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased] @@ -98,8 +101,11 @@ sinkFileMinio fileContentContent = do case nextChunk of Nothing -> putMVar chunk Nothing - Just nextChunk' - -> putMVar chunk (Just nextChunk') >> yield nextChunk' >> putChunks + Just nextChunk' -> do + observeSunkChunk StorageMinio $ olength nextChunk' + putMVar chunk $ Just nextChunk' + yield nextChunk' + putChunks sinkAsync <- lift . allocateLinkedAsync . runConduit $ fileContentContent .| putChunks diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2fa06586a..a87f20b21 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- `WidgetT`, `HandlerT` module Utils.Form where @@ -229,6 +229,8 @@ data FormIdentifier | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDAllocationAccept | FIDTestDownload + | FIDAllocationRegister + | FIDAllocationNotification deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/I18n.hs b/src/Utils/I18n.hs new file mode 100644 index 000000000..2645230e2 --- /dev/null +++ b/src/Utils/I18n.hs @@ -0,0 +1,44 @@ +module Utils.I18n + ( i18nWidgetFilesAvailable, i18nWidgetFilesAvailable' + ) where + +import ClassyPrelude +import Settings.Locale (appLanguages) + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (qRunIO) +import qualified Language.Haskell.TH.Syntax as TH + +import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import qualified Data.Text as Text + +import System.FilePath +import System.Directory (listDirectory) + +import Utils.NTop + +import Control.Lens (iforM) +import Control.Monad.Fail (fail) + + + +i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text)) +i18nWidgetFilesAvailable' basename = do + let i18nDirectory = "templates" > "i18n" > basename + availableFiles <- qRunIO $ listDirectory i18nDirectory + let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles + fileKinds :: Map Text [Text] + fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ] + toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds') + + iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty + +i18nWidgetFilesAvailable :: FilePath -> Q Exp +i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable' + diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index f6a9d2329..cb593c0c1 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -91,6 +91,10 @@ data Icon | IconCurrent | IconForward | IconFastForward + | IconNotification | IconNoNotification + | IconAllocationRegister | IconAllocationRegistrationEdit + | IconAllocationApplicationEdit + | IconPersonalIdentification deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) iconText :: Icon -> Text @@ -160,6 +164,12 @@ iconText = \case IconCurrent -> "circle" IconForward -> "angle-right" IconFastForward -> "angle-double-right" + IconNotification -> "envelope" + IconNoNotification -> "times" + IconAllocationRegister -> "user-plus" + IconAllocationRegistrationEdit -> "pencil-alt" + IconAllocationApplicationEdit -> "pencil-alt" + IconPersonalIdentification -> "id-card" instance Universe Icon instance Finite Icon diff --git a/src/Utils/Metrics.hs b/src/Utils/Metrics.hs index 34265c36a..c1f6a7abf 100644 --- a/src/Utils/Metrics.hs +++ b/src/Utils/Metrics.hs @@ -1,12 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} + module Utils.Metrics ( withHealthReportMetrics , registerGHCMetrics , observeHTTPRequestLatency , registerReadyMetric - , withJobWorkerStateLbls + , withJobWorkerState , observeYesodCacheSize , observeFavouritesQuickActionsDuration , LoginOutcome(..), observeLoginOutcome + , registerJobHeldLocksCount + , FileChunkStorage(..), observeSourcedChunk, observeSunkChunk + , observeDeletedUnreferencedFiles, observeDeletedUnreferencedChunks, observeInjectedFiles, observeRechunkedFiles + , registerJobWorkerQueueDepth + , observeMissingFiles ) where import Import.NoModel hiding (Vector, Info) @@ -25,6 +32,13 @@ import qualified Network.HTTP.Types as HTTP import Yesod.Core.Types (HandlerData(..), GHState(..)) +import qualified Data.Set as Set + +import Jobs.Types + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HashMap + {-# ANN module ("HLint: ignore Use even" :: String) #-} @@ -82,7 +96,7 @@ jobWorkerStateDuration :: Vector Label4 Histogram jobWorkerStateDuration = unsafeRegister . vector ("worker", "state", "jobctl", "task") $ histogram info buckets where info = Info "uni2work_job_worker_state_duration_seconds" "Duration of time a Uni2work job executor spent in a certain state" - buckets = histogramBuckets 1e-6 500 + buckets = histogramBuckets 1e-6 5000 {-# NOINLINE jobWorkerStateTransitions #-} jobWorkerStateTransitions :: Vector Label4 Counter @@ -110,6 +124,98 @@ loginOutcomes = unsafeRegister . vector ("plugin", "outcome") $ counter info where info = Info "uni2work_login_attempts_total" "Number of login attempts" +data JobHeldLocksCount = MkJobHeldLocksCount + +jobHeldLocksCount :: TVar (Set QueuedJobId) -> Metric JobHeldLocksCount +jobHeldLocksCount heldLocks = Metric $ return (MkJobHeldLocksCount, collectJobHeldLocksCount) + where + collectJobHeldLocksCount = do + nLocks <- Set.size <$> readTVarIO heldLocks + let sample = encodeUtf8 $ tshow nLocks + return [SampleGroup info GaugeType [Sample "uni2work_jobs_held_locks_count" [] sample]] + info = Info "uni2work_jobs_held_locks_count" + "Number of job locks currently held by this Uni2work-instance" + +{-# NOINLINE sourcedFileChunkSizes #-} +sourcedFileChunkSizes :: Vector Label1 Histogram +sourcedFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets + where info = Info "uni2work_sourced_file_chunks_bytes" + "Sizes of file chunks sourced" + buckets = 0 : histogramBuckets 1 1000000000 + +{-# NOINLINE sunkFileChunkSizes #-} +sunkFileChunkSizes :: Vector Label1 Histogram +sunkFileChunkSizes = unsafeRegister . vector "storage" $ histogram info buckets + where info = Info "uni2work_sunk_file_chunks_bytes" + "Sizes of file chunks sunk" + buckets = 0 : histogramBuckets 1 1000000000 + +{-# NOINLINE deletedUnreferencedFiles #-} +deletedUnreferencedFiles :: Counter +deletedUnreferencedFiles = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_files_count" + "Number of unreferenced files deleted" + +{-# NOINLINE deletedUnreferencedChunks #-} +deletedUnreferencedChunks :: Counter +deletedUnreferencedChunks = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_chunks_count" + "Number of unreferenced chunks deleted" + +{-# NOINLINE deletedUnreferencedChunksBytes #-} +deletedUnreferencedChunksBytes :: Counter +deletedUnreferencedChunksBytes = unsafeRegister $ counter info + where info = Info "uni2work_deleted_unreferenced_chunks_bytes" + "Size of unreferenced chunks deleted" + +{-# NOINLINE injectedFiles #-} +injectedFiles :: Counter +injectedFiles = unsafeRegister $ counter info + where info = Info "uni2work_injected_files_count" + "Number of files injected from upload cache into database" + +{-# NOINLINE injectedFilesBytes #-} +injectedFilesBytes :: Counter +injectedFilesBytes = unsafeRegister $ counter info + where info = Info "uni2work_injected_files_bytes" + "Size of files injected from upload cache into database" + +{-# NOINLINE rechunkedFiles #-} +rechunkedFiles :: Counter +rechunkedFiles = unsafeRegister $ counter info + where info = Info "uni2work_rechunked_files_count" + "Number of files rechunked within database" + +{-# NOINLINE rechunkedFilesBytes #-} +rechunkedFilesBytes :: Counter +rechunkedFilesBytes = unsafeRegister $ counter info + where info = Info "uni2work_rechunked_files_bytes" + "Size of files rechunked within database" + +data JobWorkerQueueDepth = MkJobWorkerQueueDepth + +jobWorkerQueueDepth :: TMVar JobState -> Metric JobWorkerQueueDepth +jobWorkerQueueDepth jSt = Metric $ return (MkJobWorkerQueueDepth, collectJobWorkerQueueDepth) + where + collectJobWorkerQueueDepth = maybeT (return []) $ do + wQueues <- hoist atomically $ do + JobState{..} <- MaybeT $ tryReadTMVar jSt + flip ifoldMapM jobWorkers $ \wAsync wQueue + -> lift $ pure . (jobWorkerName wAsync, ) . jqDepth <$> readTVar wQueue + return [ SampleGroup info GaugeType + [ Sample "uni2work_queued_jobs_count" [("worker", showWorkerId wName)] . encodeUtf8 $ tshow wDepth + | (wName, wDepth) <- wQueues + ] + ] + info = Info "uni2work_queued_jobs_count" + "Number of JobQueue entries in this Uni2work-instance" + +{-# NOINLINE missingFiles #-} +missingFiles :: Vector Label1 Gauge +missingFiles = unsafeRegister . vector "ref" $ gauge info + where info = Info "uni2work_missing_files_count" + "Number of files referenced from within database that are missing" + withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics act = do @@ -152,6 +258,20 @@ observeHTTPRequestLatency classifyHandler app req respond' = do registerReadyMetric :: MonadIO m => m () registerReadyMetric = liftIO $ void . register . readyMetric =<< getPOSIXTime +classifyJobWorkerState :: JobWorkerId -> JobWorkerState -> Prometheus.Label4 +classifyJobWorkerState wId jws = (showWorkerId wId, tag, maybe "n/a" pack mJobCtl, maybe "n/a" pack mJob) + where + Aeson.Object obj = Aeson.toJSON jws + Aeson.String tag = obj HashMap.! "state" + mJobCtl = asum + [ classifyJobCtl <$> jws ^? _jobWorkerJobCtl + , "perform" <$ jws ^? _jobWorkerJob + ] + mJob = classifyJob <$> jws ^? _jobWorkerJob + +withJobWorkerState :: (MonadIO m, MonadMask m) => JobWorkerId -> JobWorkerState -> m a -> m a +withJobWorkerState wId newSt = withJobWorkerStateLbls $ classifyJobWorkerState wId newSt + withJobWorkerStateLbls :: (MonadIO m, MonadMask m) => Label4 -> m a -> m a withJobWorkerStateLbls newLbls act = do liftIO $ withLabel jobWorkerStateTransitions newLbls incCounter @@ -196,3 +316,42 @@ observeLoginOutcome :: MonadHandler m -> m () observeLoginOutcome plugin outcome = liftIO $ withLabel loginOutcomes (plugin, toPathPiece outcome) incCounter + +registerJobHeldLocksCount :: MonadIO m => TVar (Set QueuedJobId) -> m () +registerJobHeldLocksCount = liftIO . void . register . jobHeldLocksCount + +data FileChunkStorage = StorageMinio | StorageDB + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) +nullaryPathPiece ''FileChunkStorage $ camelToPathPiece' 1 + +observeSunkChunk, observeSourcedChunk :: (Integral n, MonadIO m) => FileChunkStorage -> n -> m () +observeSunkChunk store = liftIO . observeChunkSize sunkFileChunkSizes store . fromIntegral +observeSourcedChunk store = liftIO . observeChunkSize sourcedFileChunkSizes store . fromIntegral + +observeChunkSize :: Vector Label1 Histogram -> FileChunkStorage -> Integer -> IO () +observeChunkSize metric (toPathPiece -> storageLabel) = withLabel metric storageLabel . flip observe . fromInteger + +observeDeletedUnreferencedFiles :: MonadIO m => Natural -> m () +observeDeletedUnreferencedFiles = liftIO . void . addCounter deletedUnreferencedFiles . fromIntegral + +observeDeletedUnreferencedChunks :: MonadIO m => Natural -> Word64 -> m () +observeDeletedUnreferencedChunks num size = liftIO $ do + void . addCounter deletedUnreferencedChunks $ fromIntegral num + void . addCounter deletedUnreferencedChunksBytes $ fromIntegral size + +observeInjectedFiles :: MonadIO m => Natural -> Word64 -> m () +observeInjectedFiles num size = liftIO $ do + void . addCounter injectedFiles $ fromIntegral num + void . addCounter injectedFilesBytes $ fromIntegral size + +observeRechunkedFiles :: MonadIO m => Natural -> Word64 -> m () +observeRechunkedFiles num size = liftIO $ do + void . addCounter rechunkedFiles $ fromIntegral num + void . addCounter rechunkedFilesBytes $ fromIntegral size + +registerJobWorkerQueueDepth :: MonadIO m => TMVar JobState -> m () +registerJobWorkerQueueDepth = liftIO . void . register . jobWorkerQueueDepth + +observeMissingFiles :: MonadIO m => Text -> Int -> m () +observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip setGauge . fromIntegral diff --git a/src/Utils/NTop.hs b/src/Utils/NTop.hs new file mode 100644 index 000000000..1199f26c3 --- /dev/null +++ b/src/Utils/NTop.hs @@ -0,0 +1,17 @@ +module Utils.NTop + ( NTop(..) + ) where + +import ClassyPrelude + +-- | treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom +newtype NTop a = NTop { nBot :: a } + deriving (Read, Show, Generic, Typeable) + deriving newtype (Eq) + +instance Ord a => Ord (NTop (Maybe a)) where + compare (NTop Nothing) (NTop Nothing) = EQ + compare (NTop Nothing) _ = GT + compare _ (NTop Nothing) = LT + compare (NTop (Just x)) (NTop (Just y)) = compare x y + diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 11be9154b..1d466b689 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -8,6 +8,7 @@ module Utils.PathPiece , tuplePathPiece , pathPieceJSON, pathPieceJSONKey , pathPieceBinary + , pathPieceHttpApiData ) where import ClassyPrelude.Yesod @@ -27,7 +28,7 @@ import qualified Data.HashMap.Strict as HashMap import Numeric.Natural -import Data.List (foldl) +import Data.List (nub, foldl) import Data.Aeson.Types import qualified Data.Aeson.Types as Aeson @@ -37,6 +38,11 @@ import Control.Monad.Fail import Data.Binary (Binary) import qualified Data.Binary as Binary +import Control.Lens +import Data.Generics.Product.Types + +import Web.HttpApiData + mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) mkFiniteFromPathPiece finiteType = do @@ -105,7 +111,7 @@ derivePathPiece adt mangle joinPP = do [] finDecs = [ pragInlD mapName NoInline FunLike AllPhases - , sigD mapName [t|HashMap Text ([Text] -> Maybe $(conT adt))|] + , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|] , funD mapName [ clause [] (normalB finClause) [] ] ] @@ -123,8 +129,17 @@ derivePathPiece adt mangle joinPP = do , match wildP (normalB [e|Nothing|]) [] ] ] + typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars + iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes + where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars + usesVar ConstructorInfo{..} n + | n `elem` map tvarName constructorVars = False + | otherwise = any (elemOf types n) constructorFields + fieldTypes = nub $ concatMap constructorFields datatypeCons + tvarName (PlainTV n) = n + tvarName (KindedTV n _) = n sequence . (finDecs ++ ) . pure $ - instanceD (cxt []) [t|PathPiece $(conT adt)|] + instanceD (cxt iCxt) [t|PathPiece $(typ)|] [ funD 'toPathPiece (map toClause datatypeCons) , funD 'fromPathPiece @@ -217,3 +232,11 @@ pathPieceBinary tName get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece put = Binary.put . toPathPiece |] + +pathPieceHttpApiData :: Name -> DecsQ +pathPieceHttpApiData tName + = [d| instance ToHttpApiData $(conT tName) where + toUrlPiece = toPathPiece + instance FromHttpApiData $(conT tName) where + parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece + |] diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index ad51820d0..b88932062 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -1,5 +1,5 @@ module Utils.Sql - ( setSerializable, setSerializable' + ( setSerializable, setSerializableBatch, setSerializable' , catchSql, handleSql , isUniqueConstraintViolation , catchIfSql, handleIfSql @@ -27,9 +27,20 @@ import Control.Monad.Random.Class (MonadRandom(getRandom)) import Text.Shakespeare.Text (st) +import Control.Concurrent.Async (ExceptionInLinkedThread(..)) + + +fromExceptionWrapped :: Exception exc => SomeException -> Maybe exc +fromExceptionWrapped (fromException -> Just exc) = Just exc +fromExceptionWrapped (fromException >=> \(ExceptionInLinkedThread _ exc') -> fromExceptionWrapped exc' -> Just exc) = Just exc +fromExceptionWrapped _ = Nothing + setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 + +setSerializableBatch :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => SqlPersistT m a -> SqlPersistT m a +setSerializableBatch = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 3600e6 setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m, ReadLogSettings (SqlPersistT m)) => RetryPolicyM (SqlPersistT m) -> SqlPersistT m a -> ReaderT SqlBackend m a setSerializable' policy act = do @@ -37,12 +48,12 @@ setSerializable' policy act = do didCommit <- newTVarIO False recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry (logRetry logSerializableTransactionRetryLimit)) $ act' didCommit where - suggestRetry :: SqlError -> ReaderT SqlBackend m Bool - suggestRetry = return . isSerializationError + suggestRetry :: SomeException -> ReaderT SqlBackend m Bool + suggestRetry = return . maybe False isSerializationError . fromExceptionWrapped logRetry :: Maybe Natural -> Bool -- ^ Will retry - -> SqlError + -> SomeException -> RetryStatus -> ReaderT SqlBackend m () logRetry _ shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status @@ -71,10 +82,11 @@ handleSql :: forall m a. (MonadCatch m, MonadIO m) => (SqlError -> SqlPersistT m handleSql recover act = do savepointName <- liftIO $ UUID.toString <$> getRandom - let recover' :: SqlError -> SqlPersistT m a - recover' exc = do + let recover' :: SomeException -> SqlPersistT m a + recover' (fromExceptionWrapped -> Just exc) = do rawExecute [st|ROLLBACK TO SAVEPOINT "#{savepointName}"|] [] recover exc + recover' exc = throwM exc handle recover' $ do rawExecute [st|SAVEPOINT "#{savepointName}"|] [] diff --git a/src/Utils/SystemMessage.hs b/src/Utils/SystemMessage.hs index 214cf5b65..9d78b2690 100644 --- a/src/Utils/SystemMessage.hs +++ b/src/Utils/SystemMessage.hs @@ -7,10 +7,9 @@ import Data.List (findIndex) getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend) - => NonEmpty Lang -- ^ `appLanguages` - -> SystemMessageId + => SystemMessageId -> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation)) -getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do +getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do SystemMessage{..} <- MaybeT $ get smId translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] [] let diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b233aaa73..b218011d1 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -13,8 +13,18 @@ import Language.Haskell.TH.Datatype import Data.List ((!!), foldl) +import Control.Lens import Control.Monad.Fail +import Utils.I18n + +import qualified Data.Char as Char +import Data.Universe (Universe, Finite) +import qualified Data.Map as Map +import qualified Data.Text as Text + +import Utils.PathPiece + ------------ -- Tuples -- ------------ @@ -188,3 +198,56 @@ dispatchTH dType = do let fName = mkName $ "dispatch" <> nameBase constructorName match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) [] lamCaseE matches + + +mkI18nWidgetEnum :: String -> FilePath -> DecsQ +mkI18nWidgetEnum (splitCamel -> namebase) basename = do + itemsAvailable <- i18nWidgetFilesAvailable' basename + let items = Map.mapWithKey (\k _ -> typPrefix <> unPathPiece k) itemsAvailable + sequence + [ dataD (cxt []) dataName [] Nothing + [ normalC (mkName conName) [] + | (_, conName) <- Map.toAscList items + ] + [ derivClause (Just StockStrategy) + [ conT ''Eq + , conT ''Ord + , conT ''Read + , conT ''Show + , conT ''Enum + , conT ''Bounded + , conT ''Generic + , conT ''Typeable + ] + , derivClause (Just AnyclassStrategy) + [ conT ''Universe + , conT ''Finite + ] + ] + , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName) + [ funD 'toPathPiece + [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) [] + | (int, con) <- Map.toList items + ] + , funD 'fromPathPiece + [ clause [varP $ mkName "t"] + ( guardedB + [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|] + | (int, con) <- Map.toList items + ]) [] + , clause [wildP] (normalB [e|Nothing|]) [] + ] + ] + , sigD (mkName $ valPrefix <> "ItemMap") [t|Map Text $(conT dataName)|] + , funD (mkName $ valPrefix <> "ItemMap") + [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) [] + ] + ] + where + unPathPiece :: Text -> String + unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-" + + dataName = mkName $ typPrefix <> "Item" + + typPrefix = concat $ over (takingWhile Char.isLower $ _head . traverse) Char.toUpper namebase + valPrefix = concat $ over (takingWhile Char.isUpper $ _head . traverse) Char.toLower namebase diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 924c27673..50f96b0ad 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -24,24 +24,18 @@ import Language.Haskell.TH import Control.Monad.Reader (MonadReader(..)) import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Base (MonadBase) -import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Catch (MonadMask, MonadCatch) +import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Random.Class (MonadRandom) import Control.Monad.Morph (MFunctor, MMonad) + +import Yesod.Core.Types.Instances.Catch () deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site) -deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) - -deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) -deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) -deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) - deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site) deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site) deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site) diff --git a/src/Yesod/Core/Types/Instances/Catch.hs b/src/Yesod/Core/Types/Instances/Catch.hs new file mode 100644 index 000000000..8e2a8388b --- /dev/null +++ b/src/Yesod/Core/Types/Instances/Catch.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Yesod.Core.Types.Instances.Catch + () where + +import ClassyPrelude.Yesod +import Yesod.Core.Types + +import Control.Monad.Catch (MonadMask, MonadCatch) + + +deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site) + +deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site) +deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site) +deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site) diff --git a/stack.yaml b/stack.yaml index fbbcd4aaa..9ea2e6ee1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -75,6 +75,9 @@ extra-deps: - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314 - primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604 + - aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 + - data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 + - strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 resolver: nightly-2020-08-08 compiler: ghc-8.10.2 diff --git a/stack.yaml.lock b/stack.yaml.lock index 053ebc2d9..d36679f52 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -359,6 +359,27 @@ packages: sha256: 924e88629b493abb6b2f3c3029cef076554a2b627091e3bb6887ec03487a707d original: hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604 +- completed: + hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 + pantry-tree: + size: 39759 + sha256: 6290ffac2ea3e52b57d869306d12dbf32c07d17099f695f035ff7f756677831d + original: + hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906 +- completed: + hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 + pantry-tree: + size: 261 + sha256: 6cf43af344624e087dbe2f1e96e985de6142e85bb02db8449df6d72bee3c1013 + original: + hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645 +- completed: + hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 + pantry-tree: + size: 654 + sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908 + original: + hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200 snapshots: - completed: size: 524392 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index ec3a41cce..b99a98218 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -65,7 +65,7 @@ $newline never
^{formatTimeW SelFormatDateTime toT}
-
+ _{MsgAllocationNotificationNewCourseTip}
+
+ $case requiredEquipment
+ $of ExamRequiredEquipmentPreset p
+ ^{examRequiredEquipmentPresetWidget p}
+ $of ExamRequiredEquipmentCustom c
+ #{c}
+
+ ^{notificationPersonalIdentification}
$maybe room <- examRoom
_{MsgAllocationParticipation}
$if is _Nothing muid
@@ -94,6 +94,18 @@ $newline never
$# This redundant links prevents useless help requests from frantic users
^{allocationInfoModal}
+
+ _{MsgAllocationNotificationNewCourse}
+ $if is _Just muid
+
+ _{bool MsgAllocationNotificationNewCourseCurrentlyOff MsgAllocationNotificationNewCourseCurrentlyOn wouldNotifyNewCourse}
+ ^{notificationForm'}
+ $else
+ _{MsgAllocationNotificationLoginFirst}
+
$if not (null courseWidgets)
diff --git a/templates/changelog.hamlet b/templates/changelog.hamlet
new file mode 100644
index 000000000..88f977759
--- /dev/null
+++ b/templates/changelog.hamlet
@@ -0,0 +1,14 @@
+$newline never
+
+ $forall (Down d, es) <- Map.toList changelogEntries
+
+ $forall e <- Set.toList es
+
$if not examVisible
+Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.
diff --git a/templates/i18n/changelog/abolish-course-associated-study-features.en-eu.hamlet b/templates/i18n/changelog/abolish-course-associated-study-features.en-eu.hamlet
new file mode 100644
index 000000000..06add0a69
--- /dev/null
+++ b/templates/i18n/changelog/abolish-course-associated-study-features.en-eu.hamlet
@@ -0,0 +1,4 @@
+$newline never
+Abolished course-associated features of study.
+
+In course-related contexts now all study features which were up to date during the relevant term are displayed.
diff --git a/templates/i18n/changelog/account-deletion-during-testing.de-de-formal.hamlet b/templates/i18n/changelog/account-deletion-during-testing.de-de-formal.hamlet
new file mode 100644
index 000000000..deecc7ecd
--- /dev/null
+++ b/templates/i18n/changelog/account-deletion-during-testing.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Benutzer können sich in der Testphase komplett selbst löschen
diff --git a/templates/i18n/changelog/account-deletion-during-testing.en-eu.hamlet b/templates/i18n/changelog/account-deletion-during-testing.en-eu.hamlet
new file mode 100644
index 000000000..c06dc9956
--- /dev/null
+++ b/templates/i18n/changelog/account-deletion-during-testing.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+During testing users may completely delete their accounts
diff --git a/templates/i18n/changelog/additional-datetime-formats.de-de-formal.hamlet b/templates/i18n/changelog/additional-datetime-formats.de-de-formal.hamlet
new file mode 100644
index 000000000..14a463e23
--- /dev/null
+++ b/templates/i18n/changelog/additional-datetime-formats.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Zusätzliche Uhrzeit- und Datumsformate
diff --git a/templates/i18n/changelog/additional-datetime-formats.en-eu.hamlet b/templates/i18n/changelog/additional-datetime-formats.en-eu.hamlet
new file mode 100644
index 000000000..5b8a068a5
--- /dev/null
+++ b/templates/i18n/changelog/additional-datetime-formats.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Additional date and time formats
diff --git a/templates/i18n/changelog/additional-sheet-notifications.de-de-formal.hamlet b/templates/i18n/changelog/additional-sheet-notifications.de-de-formal.hamlet
new file mode 100644
index 000000000..0dc85d9f2
--- /dev/null
+++ b/templates/i18n/changelog/additional-sheet-notifications.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Zusätzliche Benachrichtigungen für Übungsblätter
diff --git a/templates/i18n/changelog/additional-sheet-notifications.en-eu.hamlet b/templates/i18n/changelog/additional-sheet-notifications.en-eu.hamlet
new file mode 100644
index 000000000..2e15f4f5e
--- /dev/null
+++ b/templates/i18n/changelog/additional-sheet-notifications.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Additional notifications for exercise sheets
diff --git a/templates/i18n/changelog/allocation-applications.de-de-formal.hamlet b/templates/i18n/changelog/allocation-applications.de-de-formal.hamlet
new file mode 100644
index 000000000..e888c5003
--- /dev/null
+++ b/templates/i18n/changelog/allocation-applications.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Bewerbungen für Zentralanmeldungen
diff --git a/templates/i18n/changelog/allocation-applications.en-eu.hamlet b/templates/i18n/changelog/allocation-applications.en-eu.hamlet
new file mode 100644
index 000000000..39c759990
--- /dev/null
+++ b/templates/i18n/changelog/allocation-applications.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Applications for central allocations
diff --git a/templates/i18n/changelog/allocation-course-registration.de-de-formal.hamlet b/templates/i18n/changelog/allocation-course-registration.de-de-formal.hamlet
new file mode 100644
index 000000000..441fc07b2
--- /dev/null
+++ b/templates/i18n/changelog/allocation-course-registration.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kurse zu Zentralanmeldungen eintragen
diff --git a/templates/i18n/changelog/allocation-course-registration.en-eu.hamlet b/templates/i18n/changelog/allocation-course-registration.en-eu.hamlet
new file mode 100644
index 000000000..736472525
--- /dev/null
+++ b/templates/i18n/changelog/allocation-course-registration.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Registration of courses for central allocation
diff --git a/templates/i18n/changelog/allocation-new-course-notification.de-de-formal.hamlet b/templates/i18n/changelog/allocation-new-course-notification.de-de-formal.hamlet
new file mode 100644
index 000000000..4c56795b3
--- /dev/null
+++ b/templates/i18n/changelog/allocation-new-course-notification.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden
diff --git a/templates/i18n/changelog/allocation-new-course-notification.en-eu.hamlet b/templates/i18n/changelog/allocation-new-course-notification.en-eu.hamlet
new file mode 100644
index 000000000..be55c108d
--- /dev/null
+++ b/templates/i18n/changelog/allocation-new-course-notification.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Notifications for new courses being added to central allocations
diff --git a/templates/i18n/changelog/allocations-notifications.de-de-formal.hamlet b/templates/i18n/changelog/allocations-notifications.de-de-formal.hamlet
new file mode 100644
index 000000000..9abca1630
--- /dev/null
+++ b/templates/i18n/changelog/allocations-notifications.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Benachrichtigungen für Zentralanmeldungen
diff --git a/templates/i18n/changelog/allocations-notifications.en-eu.hamlet b/templates/i18n/changelog/allocations-notifications.en-eu.hamlet
new file mode 100644
index 000000000..8c4e6d58b
--- /dev/null
+++ b/templates/i18n/changelog/allocations-notifications.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Notifications for central allocations
diff --git a/templates/i18n/changelog/asidenav.de-de-formal.hamlet b/templates/i18n/changelog/asidenav.de-de-formal.hamlet
new file mode 100644
index 000000000..ed69dfe36
--- /dev/null
+++ b/templates/i18n/changelog/asidenav.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Designänderungen
diff --git a/templates/i18n/changelog/asidenav.en-eu.hamlet b/templates/i18n/changelog/asidenav.en-eu.hamlet
new file mode 100644
index 000000000..f07e4024a
--- /dev/null
+++ b/templates/i18n/changelog/asidenav.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Design changes
diff --git a/templates/i18n/changelog/assigned-corrections-filters.de-de-formal.hamlet b/templates/i18n/changelog/assigned-corrections-filters.de-de-formal.hamlet
new file mode 100644
index 000000000..19140c401
--- /dev/null
+++ b/templates/i18n/changelog/assigned-corrections-filters.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Liste zugewiesener Abgaben lassen sich nun filtern
diff --git a/templates/i18n/changelog/assigned-corrections-filters.en-eu.hamlet b/templates/i18n/changelog/assigned-corrections-filters.en-eu.hamlet
new file mode 100644
index 000000000..dfa3a45e2
--- /dev/null
+++ b/templates/i18n/changelog/assigned-corrections-filters.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Filters for list of assigned corrections
diff --git a/templates/i18n/changelog/automatically-accept-course-applications.de-de-formal.hamlet b/templates/i18n/changelog/automatically-accept-course-applications.de-de-formal.hamlet
new file mode 100644
index 000000000..9a8d775ac
--- /dev/null
+++ b/templates/i18n/changelog/automatically-accept-course-applications.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Automatische Anmeldung von Bewerbern in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung)
diff --git a/templates/i18n/changelog/automatically-accept-course-applications.en-eu.hamlet b/templates/i18n/changelog/automatically-accept-course-applications.en-eu.hamlet
new file mode 100644
index 000000000..ce234699b
--- /dev/null
+++ b/templates/i18n/changelog/automatically-accept-course-applications.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Option to automatically accept applications for courses outside of central allocations
diff --git a/templates/i18n/changelog/better-course-communication-tutorials.de-de-formal.hamlet b/templates/i18n/changelog/better-course-communication-tutorials.de-de-formal.hamlet
new file mode 100644
index 000000000..fce341865
--- /dev/null
+++ b/templates/i18n/changelog/better-course-communication-tutorials.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Besseres Verschicken von Kursmitteilungen an Tutoriumsteilnehmer
diff --git a/templates/i18n/changelog/better-course-communication-tutorials.en-eu.hamlet b/templates/i18n/changelog/better-course-communication-tutorials.en-eu.hamlet
new file mode 100644
index 000000000..89a056989
--- /dev/null
+++ b/templates/i18n/changelog/better-course-communication-tutorials.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Better sending of course communications to tutorial participants
diff --git a/templates/i18n/changelog/better-course-participant-detail-page.de-de-formal.hamlet b/templates/i18n/changelog/better-course-participant-detail-page.de-de-formal.hamlet
new file mode 100644
index 000000000..40391a2ad
--- /dev/null
+++ b/templates/i18n/changelog/better-course-participant-detail-page.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer
diff --git a/templates/i18n/changelog/better-course-participant-detail-page.en-eu.hamlet b/templates/i18n/changelog/better-course-participant-detail-page.en-eu.hamlet
new file mode 100644
index 000000000..307cc232a
--- /dev/null
+++ b/templates/i18n/changelog/better-course-participant-detail-page.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Submissions, tutorials, and exams are now shown on the detail page for course participants
diff --git a/templates/i18n/changelog/better-csv-import.de-de-formal.hamlet b/templates/i18n/changelog/better-csv-import.de-de-formal.hamlet
new file mode 100644
index 000000000..857ac9be4
--- /dev/null
+++ b/templates/i18n/changelog/better-csv-import.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Verbesserter Workflow & Fehlerbehandlung für CSV-Import
diff --git a/templates/i18n/changelog/better-csv-import.en-eu.hamlet b/templates/i18n/changelog/better-csv-import.en-eu.hamlet
new file mode 100644
index 000000000..f585e50b3
--- /dev/null
+++ b/templates/i18n/changelog/better-csv-import.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Improved workflow and error-handling for CSV-import
diff --git a/templates/i18n/changelog/better-file-uploads.de-de-formal.hamlet b/templates/i18n/changelog/better-file-uploads.de-de-formal.hamlet
new file mode 100644
index 000000000..5cf99ec89
--- /dev/null
+++ b/templates/i18n/changelog/better-file-uploads.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Verbesserte Handhabung von Datei-Uploads
diff --git a/templates/i18n/changelog/better-file-uploads.en-eu.hamlet b/templates/i18n/changelog/better-file-uploads.en-eu.hamlet
new file mode 100644
index 000000000..ff090f630
--- /dev/null
+++ b/templates/i18n/changelog/better-file-uploads.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Improved handling of file uploads
diff --git a/templates/i18n/changelog/better-table-cell-colour-coding.de-de-formal.hamlet b/templates/i18n/changelog/better-table-cell-colour-coding.de-de-formal.hamlet
new file mode 100644
index 000000000..6a0cbff54
--- /dev/null
+++ b/templates/i18n/changelog/better-table-cell-colour-coding.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Verbesserte Farbkodierung von Tabellenzellen
diff --git a/templates/i18n/changelog/better-table-cell-colour-coding.en-eu.hamlet b/templates/i18n/changelog/better-table-cell-colour-coding.en-eu.hamlet
new file mode 100644
index 000000000..1f0012e18
--- /dev/null
+++ b/templates/i18n/changelog/better-table-cell-colour-coding.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Improved colour coding of table cells
diff --git a/templates/i18n/changelog/buttons-work-without-javascript.de-de-formal.hamlet b/templates/i18n/changelog/buttons-work-without-javascript.de-de-formal.hamlet
new file mode 100644
index 000000000..651a5c3e9
--- /dev/null
+++ b/templates/i18n/changelog/buttons-work-without-javascript.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript
diff --git a/templates/i18n/changelog/buttons-work-without-javascript.en-eu.hamlet b/templates/i18n/changelog/buttons-work-without-javascript.en-eu.hamlet
new file mode 100644
index 000000000..5ac1ddb5a
--- /dev/null
+++ b/templates/i18n/changelog/buttons-work-without-javascript.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Multiple buttons/forms no work again when JavaScript is enabled
diff --git a/templates/i18n/changelog/configurable-datetime-format.de-de-formal.hamlet b/templates/i18n/changelog/configurable-datetime-format.de-de-formal.hamlet
new file mode 100644
index 000000000..d637ae8fd
--- /dev/null
+++ b/templates/i18n/changelog/configurable-datetime-format.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Wählbares Format für Datum
diff --git a/templates/i18n/changelog/configurable-datetime-format.en-eu.hamlet b/templates/i18n/changelog/configurable-datetime-format.en-eu.hamlet
new file mode 100644
index 000000000..a3d12724d
--- /dev/null
+++ b/templates/i18n/changelog/configurable-datetime-format.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Configurable date and time formats
diff --git a/templates/i18n/changelog/configurable-display-emails.de-de-formal.hamlet b/templates/i18n/changelog/configurable-display-emails.de-de-formal.hamlet
new file mode 100644
index 000000000..93e8812fa
--- /dev/null
+++ b/templates/i18n/changelog/configurable-display-emails.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Anpassbare angezeigte E-Mail Adressen
diff --git a/templates/i18n/changelog/configurable-display-emails.en-eu.hamlet b/templates/i18n/changelog/configurable-display-emails.en-eu.hamlet
new file mode 100644
index 000000000..75e9ea7de
--- /dev/null
+++ b/templates/i18n/changelog/configurable-display-emails.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Configulable display emails
diff --git a/templates/i18n/changelog/configurable-display-names.de-de-formal.hamlet b/templates/i18n/changelog/configurable-display-names.de-de-formal.hamlet
new file mode 100644
index 000000000..1c02bad41
--- /dev/null
+++ b/templates/i18n/changelog/configurable-display-names.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Anpassbare angezeigte Namen
diff --git a/templates/i18n/changelog/configurable-display-names.en-eu.hamlet b/templates/i18n/changelog/configurable-display-names.en-eu.hamlet
new file mode 100644
index 000000000..d0708619b
--- /dev/null
+++ b/templates/i18n/changelog/configurable-display-names.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Configurable display names
diff --git a/templates/i18n/changelog/corrections-display-improvements.de-de-formal.hamlet b/templates/i18n/changelog/corrections-display-improvements.de-de-formal.hamlet
new file mode 100644
index 000000000..3c7a1d5bd
--- /dev/null
+++ b/templates/i18n/changelog/corrections-display-improvements.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Viele Verbesserung zur Anzeige von Korrekturen
diff --git a/templates/i18n/changelog/corrections-display-improvements.en-eu.hamlet b/templates/i18n/changelog/corrections-display-improvements.en-eu.hamlet
new file mode 100644
index 000000000..bda6e1f73
--- /dev/null
+++ b/templates/i18n/changelog/corrections-display-improvements.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Numerous improvements for display of corrections
diff --git a/templates/i18n/changelog/correctors-on-course-show.de-de-formal.hamlet b/templates/i18n/changelog/correctors-on-course-show.de-de-formal.hamlet
new file mode 100644
index 000000000..85398c03d
--- /dev/null
+++ b/templates/i18n/changelog/correctors-on-course-show.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Anzeige von Korrektoren auf den Kursseiten
diff --git a/templates/i18n/changelog/correctors-on-course-show.en-eu.hamlet b/templates/i18n/changelog/correctors-on-course-show.en-eu.hamlet
new file mode 100644
index 000000000..c67066085
--- /dev/null
+++ b/templates/i18n/changelog/correctors-on-course-show.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Display of correctors on course overview pages
diff --git a/templates/i18n/changelog/course-administrator-invitations.de-de-formal.hamlet b/templates/i18n/changelog/course-administrator-invitations.de-de-formal.hamlet
new file mode 100644
index 000000000..bd9f67e09
--- /dev/null
+++ b/templates/i18n/changelog/course-administrator-invitations.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account
diff --git a/templates/i18n/changelog/course-administrator-invitations.en-eu.hamlet b/templates/i18n/changelog/course-administrator-invitations.en-eu.hamlet
new file mode 100644
index 000000000..0cc985bf3
--- /dev/null
+++ b/templates/i18n/changelog/course-administrator-invitations.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Configuration of course correctors and administrators without existing accounts
diff --git a/templates/i18n/changelog/course-administrator-roles.de-de-formal.hamlet b/templates/i18n/changelog/course-administrator-roles.de-de-formal.hamlet
new file mode 100644
index 000000000..b332852eb
--- /dev/null
+++ b/templates/i18n/changelog/course-administrator-roles.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen
diff --git a/templates/i18n/changelog/course-administrator-roles.en-eu.hamlet b/templates/i18n/changelog/course-administrator-roles.en-eu.hamlet
new file mode 100644
index 000000000..6d4f7b3e7
--- /dev/null
+++ b/templates/i18n/changelog/course-administrator-roles.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course administrators can now configure course administrators and assistants themselves
diff --git a/templates/i18n/changelog/course-associated-study-field.de-de-formal.hamlet b/templates/i18n/changelog/course-associated-study-field.de-de-formal.hamlet
new file mode 100644
index 000000000..260f5bb59
--- /dev/null
+++ b/templates/i18n/changelog/course-associated-study-field.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kursanmeldung benötigen assoziertes Hauptfach (für Studierende mit mehreren Hauptfächern)
diff --git a/templates/i18n/changelog/course-associated-study-field.en-eu.hamlet b/templates/i18n/changelog/course-associated-study-field.en-eu.hamlet
new file mode 100644
index 000000000..75a164dfc
--- /dev/null
+++ b/templates/i18n/changelog/course-associated-study-field.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course enrollment requires association of a field of study (for students with multiple fields)
diff --git a/templates/i18n/changelog/course-convenience-links.de-de-formal.hamlet b/templates/i18n/changelog/course-convenience-links.de-de-formal.hamlet
new file mode 100644
index 000000000..891f0186a
--- /dev/null
+++ b/templates/i18n/changelog/course-convenience-links.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt)
diff --git a/templates/i18n/changelog/course-convenience-links.en-eu.hamlet b/templates/i18n/changelog/course-convenience-links.en-eu.hamlet
new file mode 100644
index 000000000..f39a3e6b8
--- /dev/null
+++ b/templates/i18n/changelog/course-convenience-links.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Convenience links (i.e. current exercise sheet)
diff --git a/templates/i18n/changelog/course-list-over-all-terms.de-de-formal.hamlet b/templates/i18n/changelog/course-list-over-all-terms.de-de-formal.hamlet
new file mode 100644
index 000000000..631497915
--- /dev/null
+++ b/templates/i18n/changelog/course-list-over-all-terms.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kursliste über alle Semester hinweg (Top-Level-Navigation "Kurse"), wird in Zukunft Filter/Suchfunktion erhalten
diff --git a/templates/i18n/changelog/course-list-over-all-terms.en-eu.hamlet b/templates/i18n/changelog/course-list-over-all-terms.en-eu.hamlet
new file mode 100644
index 000000000..91e876e31
--- /dev/null
+++ b/templates/i18n/changelog/course-list-over-all-terms.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Overall course list for all semesters (see "Courses"), will have filters and search functions in the future
diff --git a/templates/i18n/changelog/course-materials.de-de-formal.hamlet b/templates/i18n/changelog/course-materials.de-de-formal.hamlet
new file mode 100644
index 000000000..c16c704d7
--- /dev/null
+++ b/templates/i18n/changelog/course-materials.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kursmaterial
diff --git a/templates/i18n/changelog/course-materials.en-eu.hamlet b/templates/i18n/changelog/course-materials.en-eu.hamlet
new file mode 100644
index 000000000..5d59fa499
--- /dev/null
+++ b/templates/i18n/changelog/course-materials.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course material
diff --git a/templates/i18n/changelog/course-messages.de-de-formal.hamlet b/templates/i18n/changelog/course-messages.de-de-formal.hamlet
new file mode 100644
index 000000000..1b4eab818
--- /dev/null
+++ b/templates/i18n/changelog/course-messages.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Versand von Benachrichtigungen an Kursteilnehmer
diff --git a/templates/i18n/changelog/course-messages.en-eu.hamlet b/templates/i18n/changelog/course-messages.en-eu.hamlet
new file mode 100644
index 000000000..689483fba
--- /dev/null
+++ b/templates/i18n/changelog/course-messages.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Sending of course messages to participants
diff --git a/templates/i18n/changelog/course-news.de-de-formal.hamlet b/templates/i18n/changelog/course-news.de-de-formal.hamlet
new file mode 100644
index 000000000..3fbfc3a83
--- /dev/null
+++ b/templates/i18n/changelog/course-news.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+"Aktuelles" für Kurse
diff --git a/templates/i18n/changelog/course-news.en-eu.hamlet b/templates/i18n/changelog/course-news.en-eu.hamlet
new file mode 100644
index 000000000..c6c43a3ab
--- /dev/null
+++ b/templates/i18n/changelog/course-news.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course news
diff --git a/templates/i18n/changelog/course-occurences.de-de-formal.hamlet b/templates/i18n/changelog/course-occurences.de-de-formal.hamlet
new file mode 100644
index 000000000..8688159dd
--- /dev/null
+++ b/templates/i18n/changelog/course-occurences.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kurstermine
diff --git a/templates/i18n/changelog/course-occurences.en-eu.hamlet b/templates/i18n/changelog/course-occurences.en-eu.hamlet
new file mode 100644
index 000000000..a7d77daed
--- /dev/null
+++ b/templates/i18n/changelog/course-occurences.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course occurrences
diff --git a/templates/i18n/changelog/course-occurrence-notes.de-de-formal.hamlet b/templates/i18n/changelog/course-occurrence-notes.de-de-formal.hamlet
new file mode 100644
index 000000000..0a8df117a
--- /dev/null
+++ b/templates/i18n/changelog/course-occurrence-notes.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Spalte für Notizen bei Kursterminen
diff --git a/templates/i18n/changelog/course-occurrence-notes.en-eu.hamlet b/templates/i18n/changelog/course-occurrence-notes.en-eu.hamlet
new file mode 100644
index 000000000..1051c42bf
--- /dev/null
+++ b/templates/i18n/changelog/course-occurrence-notes.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Column for adding notes to course events
diff --git a/templates/i18n/changelog/course-participants-list-add-sheets.de-de-formal.hamlet b/templates/i18n/changelog/course-participants-list-add-sheets.de-de-formal.hamlet
new file mode 100644
index 000000000..a52c5c6f4
--- /dev/null
+++ b/templates/i18n/changelog/course-participants-list-add-sheets.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Auswertung des Übungsbetriebs unter „Kursteilnehmer“
diff --git a/templates/i18n/changelog/course-participants-list-add-sheets.en-eu.hamlet b/templates/i18n/changelog/course-participants-list-add-sheets.en-eu.hamlet
new file mode 100644
index 000000000..e19954cb1
--- /dev/null
+++ b/templates/i18n/changelog/course-participants-list-add-sheets.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Inclusion of exercise sheets under “Course participants”
diff --git a/templates/i18n/changelog/course-participants-sex.de-de-formal.hamlet b/templates/i18n/changelog/course-participants-sex.de-de-formal.hamlet
new file mode 100644
index 000000000..4e459b27c
--- /dev/null
+++ b/templates/i18n/changelog/course-participants-sex.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Optionale Anzeige des Geschlechts in Teilnehmerlisten u.Ä.
diff --git a/templates/i18n/changelog/course-participants-sex.en-eu.hamlet b/templates/i18n/changelog/course-participants-sex.en-eu.hamlet
new file mode 100644
index 000000000..198c7c8a9
--- /dev/null
+++ b/templates/i18n/changelog/course-participants-sex.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Optionally display sex in (among others) lists of course participants
diff --git a/templates/i18n/changelog/course-register-by-admin.de-de-formal.hamlet b/templates/i18n/changelog/course-register-by-admin.de-de-formal.hamlet
new file mode 100644
index 000000000..edb6ec891
--- /dev/null
+++ b/templates/i18n/changelog/course-register-by-admin.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kursverwalter können Teilnehmer hinzufügen
diff --git a/templates/i18n/changelog/course-register-by-admin.en-eu.hamlet b/templates/i18n/changelog/course-register-by-admin.en-eu.hamlet
new file mode 100644
index 000000000..48c54a7a6
--- /dev/null
+++ b/templates/i18n/changelog/course-register-by-admin.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course administrators may enroll participants
diff --git a/templates/i18n/changelog/course-shorthands-within-schools.de-de-formal.hamlet b/templates/i18n/changelog/course-shorthands-within-schools.de-de-formal.hamlet
new file mode 100644
index 000000000..48a6d8d4c
--- /dev/null
+++ b/templates/i18n/changelog/course-shorthands-within-schools.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kurskürzel müssen nur innerhalb eines Instituts eindeutig sein
diff --git a/templates/i18n/changelog/course-shorthands-within-schools.en-eu.hamlet b/templates/i18n/changelog/course-shorthands-within-schools.en-eu.hamlet
new file mode 100644
index 000000000..ee559c2e8
--- /dev/null
+++ b/templates/i18n/changelog/course-shorthands-within-schools.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Course shorthands now only need to be unique within a department
diff --git a/templates/i18n/changelog/course-visibility.de-de-formal.hamlet b/templates/i18n/changelog/course-visibility.de-de-formal.hamlet
new file mode 100644
index 000000000..8592b6a43
--- /dev/null
+++ b/templates/i18n/changelog/course-visibility.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Kurse haben nun einen Sichtbarkeitszeitraum.
diff --git a/templates/i18n/changelog/course-visibility.en-eu.hamlet b/templates/i18n/changelog/course-visibility.en-eu.hamlet
new file mode 100644
index 000000000..d95f8e9d6
--- /dev/null
+++ b/templates/i18n/changelog/course-visibility.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Courses now have a visibility period.
diff --git a/templates/i18n/changelog/csv-course-applications.de-de-formal.hamlet b/templates/i18n/changelog/csv-course-applications.de-de-formal.hamlet
new file mode 100644
index 000000000..04b0b816a
--- /dev/null
+++ b/templates/i18n/changelog/csv-course-applications.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Bewertung von Kurs-Bewerbungen via CSV
diff --git a/templates/i18n/changelog/csv-course-applications.en-eu.hamlet b/templates/i18n/changelog/csv-course-applications.en-eu.hamlet
new file mode 100644
index 000000000..cd75ffb4f
--- /dev/null
+++ b/templates/i18n/changelog/csv-course-applications.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Grading of course applications via CSV
diff --git a/templates/i18n/changelog/csv-exam-participants.de-de-formal.hamlet b/templates/i18n/changelog/csv-exam-participants.de-de-formal.hamlet
new file mode 100644
index 000000000..6b9bb4062
--- /dev/null
+++ b/templates/i18n/changelog/csv-exam-participants.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Import & Export von CSV-Dateien für Klausurteilnehmer
diff --git a/templates/i18n/changelog/csv-exam-participants.en-eu.hamlet b/templates/i18n/changelog/csv-exam-participants.en-eu.hamlet
new file mode 100644
index 000000000..98f03ca6c
--- /dev/null
+++ b/templates/i18n/changelog/csv-exam-participants.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV import & export of exam participants
diff --git a/templates/i18n/changelog/csv-export-course-participants-features.de-de-formal.hamlet b/templates/i18n/changelog/csv-export-course-participants-features.de-de-formal.hamlet
new file mode 100644
index 000000000..6cc7fdcb7
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants-features.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV-Export für Liste von Kursteilnehmern exportiert nun optional alle Studiengangsdaten der Teilnehmer
diff --git a/templates/i18n/changelog/csv-export-course-participants-features.en-eu.hamlet b/templates/i18n/changelog/csv-export-course-participants-features.en-eu.hamlet
new file mode 100644
index 000000000..8e5edec78
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants-features.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV export of course participants now optionally includes all features of study
diff --git a/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.de-de-formal.hamlet b/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.de-de-formal.hamlet
new file mode 100644
index 000000000..8aeb6e503
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV-Export für Liste von Kursteilnehmern exportiert nun auch die angemeldeten Tutorien
diff --git a/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.en-eu.hamlet b/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.en-eu.hamlet
new file mode 100644
index 000000000..64ae6f239
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants-registered-tutorials.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV export of course participants now includes registered tutorials
diff --git a/templates/i18n/changelog/csv-export-course-participants.de-de-formal.hamlet b/templates/i18n/changelog/csv-export-course-participants.de-de-formal.hamlet
new file mode 100644
index 000000000..9885bcace
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV-Export für Liste von Kursteilnehmern
diff --git a/templates/i18n/changelog/csv-export-course-participants.en-eu.hamlet b/templates/i18n/changelog/csv-export-course-participants.en-eu.hamlet
new file mode 100644
index 000000000..38de032e9
--- /dev/null
+++ b/templates/i18n/changelog/csv-export-course-participants.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV export of course participants
diff --git a/templates/i18n/changelog/csv-option-character-set.de-de-formal.hamlet b/templates/i18n/changelog/csv-option-character-set.de-de-formal.hamlet
new file mode 100644
index 000000000..6b57d4aa5
--- /dev/null
+++ b/templates/i18n/changelog/csv-option-character-set.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+CSV-Export-Option um den beim import und export verwendeten Zeichensatz einzustellen
diff --git a/templates/i18n/changelog/csv-option-character-set.en-eu.hamlet b/templates/i18n/changelog/csv-option-character-set.en-eu.hamlet
new file mode 100644
index 000000000..6ef50ec74
--- /dev/null
+++ b/templates/i18n/changelog/csv-option-character-set.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Introduced CSV export option to set the character encoding used
diff --git a/templates/i18n/changelog/csv-option-timestamp.de-de-formal.hamlet b/templates/i18n/changelog/csv-option-timestamp.de-de-formal.hamlet
new file mode 100644
index 000000000..876527d8d
--- /dev/null
+++ b/templates/i18n/changelog/csv-option-timestamp.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Option um an die Namen aller heruntergeladenen CSV-Dateien einen Zeitstempel vorne anzuhängen
diff --git a/templates/i18n/changelog/csv-option-timestamp.en-eu.hamlet b/templates/i18n/changelog/csv-option-timestamp.en-eu.hamlet
new file mode 100644
index 000000000..0174c9d81
--- /dev/null
+++ b/templates/i18n/changelog/csv-option-timestamp.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Introduced option to timestamp all exported CSV files
diff --git a/templates/i18n/changelog/de-de-formal.hamlet b/templates/i18n/changelog/de-de-formal.hamlet
deleted file mode 100644
index e0e41fb22..000000000
--- a/templates/i18n/changelog/de-de-formal.hamlet
+++ /dev/null
@@ -1,456 +0,0 @@
-$newline never
-
-
-
- Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
- (Ersatz einer C-Bibliothek mit undokumentierter Abhängigkeit durch selbst entwickelten Haskell-Code erlaubt nun auch Umlaute)
-
-
-
-
-
-
- In course-related contexts now all study features which were up to date during the relevant term are displayed.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-