diff --git a/CHANGELOG.md b/CHANGELOG.md index b4f2bc1d0..273f62a13 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,140 @@ 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. +### [7.9.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.9.0...v7.9.1) (2019-10-07) + + +### Bug Fixes + +* allow deregistering from full courses ([d7e1e67](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d7e1e67)) + + + +## [7.9.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.5...v7.9.0) (2019-10-05) + + +### Features + +* **allocations:** show more information ([b7c54df](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b7c54df)) + + + +### [7.8.5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.4...v7.8.5) (2019-10-05) + + +### Bug Fixes + +* fix form-notification styling ([0226593](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0226593)) + + + +### [7.8.4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.3...v7.8.4) (2019-10-05) + + +### Bug Fixes + +* **course-user:** handle allocations when deregistering single users ([ef5bb70](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ef5bb70)) + + + +### [7.8.3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.2...v7.8.3) (2019-10-05) + + +### Bug Fixes + +* typo ([a6e40f1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a6e40f1)) + + + +### [7.8.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.1...v7.8.2) (2019-10-04) + + +### Bug Fixes + +* **favourites:** always move current course up ([56d89d7](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56d89d7)) + + + +### [7.8.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.8.0...v7.8.1) (2019-10-04) + + +### Bug Fixes + +* **allocation:** fix allocation-results notifications ([ed700a3](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ed700a3)) + + + +## [7.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.7.0...v7.8.0) (2019-10-04) + + +### Bug Fixes + +* ordinalPriorities ([d4ab6f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d4ab6f6)) + + +### Features + +* **course:** show direct registration dates ([8f284ac](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8f284ac)) + + + +## [7.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.6.0...v7.7.0) (2019-10-04) + + +### Features + +* **allocations:** fingerprints & ordinal ratings ([60603cb](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/60603cb)) + + + +## [7.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.5.0...v7.6.0) (2019-10-04) + + +### Features + +* **allocations:** notification about finished allocation ([9323220](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9323220)) +* **allocations:** properly save allocation-relevant course-deregs ([7a759b1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7a759b1)) +* **favourites:** usability improvements ([fccc2ea](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fccc2ea)) + + + +## [7.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.2...v7.5.0) (2019-10-03) + + +### Features + +* **allocations:** auxilliaries for allocation-algo ([47bfd8d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/47bfd8d)) +* **allocations:** prototype assignment-algorithm ([0fcf48c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0fcf48c)) + + + +### [7.4.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.1...v7.4.2) (2019-10-01) + + +### Bug Fixes + +* **course-news:** prevent display of edit-functions unless auth'ed ([89cc9ad](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/89cc9ad)) + + + +### [7.4.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.4.0...v7.4.1) (2019-10-01) + + +### Bug Fixes + +* **course-news:** fix permissions ([9e5fde9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9e5fde9)) + + + +## [7.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.2...v7.4.0) (2019-10-01) + + +### Features + +* **course:** introduce CourseNews ([aa93b75](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/aa93b75)) + + + ### [7.3.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v7.3.1...v7.3.2) (2019-10-01) diff --git a/config/settings.yml b/config/settings.yml index 12150c38e..0e2dbe810 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -122,13 +122,23 @@ widget-memcached: expiration: "_env:MEMCACHEDEXPIRATION:3600" user-defaults: - max-favourites: 12 - theme: Default - date-time-format: "%a %d %b %Y %R" - date-format: "%d.%m.%Y" - time-format: "%R" - download-files: false - warning-days: 1209600 + max-favourites: 12 + max-favourite-terms: 2 + theme: Default + date-time-format: "%a %d %b %Y %R" + date-format: "%d.%m.%Y" + time-format: "%R" + download-files: false + warning-days: 1209600 + +# During central allocations lecturer-given ratings of applications (as +# ExamGrades) are combined with a central priority. +# This encodes the weight of the lecturer ratings on the same scale as the +# centrally supplied priorities. +allocation-grade-scale: 25 +# This encodes how many ordinal places lecturer ratings may move students up or +# down when central priorities are supplied as ordered list. +allocation-grade-ordinal-places: 3 instance-id: "_env:INSTANCE_ID:instance" ribbon: "_env:RIBBON:" diff --git a/frontend/src/utils/asidenav/asidenav.scss b/frontend/src/utils/asidenav/asidenav.scss index e7ab3b50d..8ef003c21 100644 --- a/frontend/src/utils/asidenav/asidenav.scss +++ b/frontend/src/utils/asidenav/asidenav.scss @@ -56,6 +56,10 @@ font-size: 18px; padding-left: 10px; } + + .asidenav__box-subtitle { + display: none; + } } } @@ -95,6 +99,14 @@ border-bottom: 1px solid var(--color-grey); } +.asidenav__box-subtitle { + color: var(--color-fontsec); + font-size: 0.9rem; + font-weight: 600; + padding: 0 13px; + margin: 3px 0; +} + /* LOGO */ .asidenav__logo { @@ -170,7 +182,7 @@ position: absolute; bottom: -40px; right: 25px; - opacity: 0.2; + opacity: 0.1; > img { width: 350px; @@ -314,8 +326,16 @@ color: var(--color-lightwhite); &:hover { - background-color: var(--color-dark); + background-color: var(--color-darker); } + + &::before { + display: none; + } + } + + .asidenav__box-subtitle { + display: none; } .asidenav__link-shorthand { diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 6d51e9334..db2469142 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -36,6 +36,10 @@ RegisterTo: Anmeldungen bis DeRegUntil: Abmeldungen bis RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden" +CourseRegistrationInterval: Anmeldung +CourseDirectRegistrationInterval: Direkte Anmeldung +CourseDeregisterUntil time@Text: Abmeldung nur bis #{time} + GenericKey: Schlüssel GenericShort: Kürzel GenericIsNew: Neu @@ -378,12 +382,14 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r UnauthorizedAllocationRegistered: Sie sind nicht als Teilnehmer für diese Zentralanmeldung registriert. UnauthorizedExamResult: Sie haben keine Ergebnisse in dieser Prüfung. UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert. +UnauthorizedCourseNewsParticipant: Sie sind kein Teilnehmer dieser Veranstaltung. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedAllocationRegisterTime: Diese Zentralanmeldung erlaubt momentan keine Bewerbungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedApplicationTime: Diese Bewerbung ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. +UnauthorizedCourseNewsTime: Diese Nachricht ist momentan nicht freigegeben. UnauthorizedExamTime: Diese Prüfung ist momentan nicht freigegeben. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. @@ -474,7 +480,9 @@ LdapSynced: LDAP-Synchronisiert LdapSyncedBefore: Letzte LDAP-Synchronisation vor NoMatrikelKnown: Keine Matrikelnummer Theme: Oberflächen Design -Favoriten: Anzahl gespeicherter Favoriten +Favourites: Anzahl gespeicherter Favoriten +FavouritesTip: Betrifft nur automatisch angelegte Favoriten („Kürzlich besucht“) +FavouriteSemesters: Maximale Anzahl an Semestern in Seitenleiste Plugin: Plugin Ident: Identifikation LastLogin: Letzter Login @@ -898,6 +906,7 @@ NotificationTriggerAllocationAllocation: Ich kann Zentralanmeldung-Bewerbungen f NotificationTriggerAllocationRegister: Ich kann mich bei einer neuen Zentralanmeldung bewerben NotificationTriggerAllocationOutdatedRatings: Zentralanmeldung-Bewerbungen für einen meiner Kurse wurden verändert, nachdem sie bewertet wurden NotificationTriggerAllocationUnratedApplications: Bewertungen zu Zentralanmeldung-Bewerbungen für einen meiner Kurse stehen aus +NotificationTriggerAllocationResults: Plätze wurden für eine meiner Zentralanmeldungen verteilt NotificationTriggerExamOfficeExamResults: Ich kann neue Prüfungsergebnisse einsehen NotificationTriggerExamOfficeExamResultsChanged: Prüfungsergebnisse wurden verändert @@ -909,7 +918,8 @@ NotificationTriggerKindLecturer: Für Dozenten NotificationTriggerKindAdmin: Für Administratoren NotificationTriggerKindExamOffice: Für das Prüfungsamt NotificationTriggerKindEvaluation: Für Vorlesungsumfragen -NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen +NotificationTriggerKindAllocationStaff: Für Zentralanmeldungen (Dozenten) +NotificationTriggerKindAllocationParticipant: Für Zentralanmeldungen CorrCreate: Abgaben erstellen UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}" @@ -1024,7 +1034,7 @@ MenuAllocationList: Zentralanmeldungen MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer MenuCourseAddMembers: Kursteilnehmer hinzufügen -MenuCourseCommunication: Kursmitteilung +MenuCourseCommunication: Kursmitteilung (E-Mail) MenuCourseApplications: Bewerbungen MenuCourseExamOffice: Prüfungsämter MenuTermShow: Semester @@ -1088,6 +1098,8 @@ MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung MenuCourseApplicationsFiles: Dateien aller Bewerbungen MenuSchoolList: Institute MenuSchoolNew: Neues Institut anlegen +MenuCourseNewsNew: Neue Kursnachricht +MenuCourseNewsEdit: Kursnachricht bearbeiten AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -1127,6 +1139,7 @@ AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab. +DeletePressButtonIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, bestätigen Sie dies bitte durch Drücken des untigen Knopfes. DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. @@ -1292,6 +1305,9 @@ HealthSMTPConnect: SMTP-Server kann erreicht werden HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +CourseParticipantsHeading: Kursteilnehmer +CourseParticipantsCount n@Int: #{n} +CourseParticipantsCountOf n@Int m@Int: #{n} von #{m} CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet @@ -1629,7 +1645,10 @@ AllocationAppliedCourses: Bewerbungen AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation} AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash} +AllocationSchool: Institut +AllocationSemester: Semester AllocationDescription: Beschreibung +AllocationStaffDescription: Beschreibung für Dozenten AllocationStaffRegisterFrom: Eintragung der Kurse ab AllocationStaffRegister: Eintragung der Kurse AllocationRegisterFrom: Bewerbung ab @@ -1638,6 +1657,13 @@ AllocationRegisterClosed: Die Zentralanmeldung ist aktuell geschlossen. AllocationRegisterOpensIn difftime@Text: Die Zentralanmeldung öffnet voraussichtlich in #{difftime} AllocationStaffAllocationFrom: Bewertung der Bewerbungen ab AllocationStaffAllocation: Bewertung der Bewerbungen +AllocationRegisterByStaff: An- und Abmeldung durch Kursverwalter +AllocationRegisterByStaffFrom: An- und Abmeldung durch Kursverwalter ab +AllocationRegisterByStaffTip: In diesem Zeitraum können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden. +AllocationRegisterByStaffFromTip: Ab diesem Zeitpunkt können Kursverwalter Teilnehmer zu und von ihren Kursen an- und abmelden. +AllocationRegisterByCourseFrom: Direkte An- und Abmeldung ab +AllocationRegisterByCourseFromTip: Frühestens ab diesem Zeitpunkt ist die eigentständige An- und Abmeldung zu und von den Kursen, die an der Zentralanmeldung teilnehmen, möglich. Kontrolle über die genauen Fristen haben die Kursverwalter. +AllocationOverrideDeregister: Abmeldung von den Kursen nur bis AllocationProcess: Platzvergabe AllocationNoApplication: Keine Bewerbung AllocationPriority: Priorität @@ -1832,3 +1858,45 @@ CsvQuoteMinimal: Nur wenn nötig CsvQuoteAll: Immer CsvOptionsUpdated: CSV-Optionen erfolgreich angepasst CsvChangeOptionsLabel: Export-Optionen + +CourseNews: Aktuelles +CourseNewsArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand newsTitle@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase newsTitle} +CourseNewsFiles: Dateien +CourseNewsLastEdited time@Text: Zuletzt verändert: #{time} +CourseNewsActionEdit: Bearbeiten +CourseNewsActionDelete: Löschen +CourseNewsActionCreate: Neue Nachricht +CourseMaterial: Material +CourseMaterialFree: Das Kursmaterial ist ohne Anmeldung frei zugänglich +CourseMaterialNotFree: Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial + +CourseNewsVisibleFromEditWarning: Das Datum der Veröffentlichung liegt in der Vergangenheit und sollte nicht mehr verändert werden, da dies die Teilnehmer verwirren könnte. +CourseNewsVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für noch unfertige Nachrichten +CourseNewsTitle: Titel +CourseNewsSummary: Zusammenfassung +CourseNewsSummaryTip: Wenn angegeben, wird auf der Kursübersichtsseite, platzsparend, nur die Zusammenfassung angezeigt und der Inhalt in ein Popup ausgelagert +CourseNewsContent: Inhalt +CourseNewsParticipantsOnly: Nur für Kursteilnehmer +CourseNewsVisibleFrom: Sichtbar ab +CourseNewsCreated: Kursnachricht erfolgreich angelegt +CourseNewsEdited: Kursnachricht erfolgreich editiert +CourseNewsDeleteQuestion: Wollen Sie die unten aufgeführte Nachricht wirklich löschen? +CourseNewsDeleted: Kursnachricht erfolgreich gelöscht + +CourseDeregistrationAllocationLog: Ihr Platz in diesem Kurs stammt aus einer Zentralanmeldung. Wenn Sie sich vom Kurs abmelden wird dieser Umstand permanent im System gespeichert und kann Sie u.U. bei zukünftigen Zentralanmeldungen benachteiligen. Wenn Sie gute Gründe vorzuweisen haben, warum Ihre Abmeldung nicht selbstverschuldet ist, kontaktieren Sie bitte einen Kursverwalter. Diese haben die Möglichkeit Sie ohne permanente Eintragung im System abzumelden. +CourseDeregistrationAllocationReason: Grund +CourseDeregistrationAllocationReasonTip: Der angegebene Grund wird permanent im System hinterlegt und ist i.A. einziger Anhaltspunkt zur Schlichtung etwaiger Konflikte +CourseDeregistrationAllocationShouldLog: Selbstverschuldet +CourseDeregistrationAllocationShouldLogTip: Falls der Platz des Studierenden, der abgemeldet wird, aus einer Zentralanmeldung stammt, ist vorgesehen einen permanenten Eintrag im System zu speichern, der den Studierenden u.U. bei zukünftigen Zentralanmeldungen benachteiligt. Als Kursverwalter haben Sie die Möglichkeit dies zu unterbinden, wenn der Studierende gute Gründe vorweisen kann, warum seine Abmeldung nicht selbstverschuldet ist. + +MailSubjectAllocationResults allocation@AllocationName: Plätze für Zentralanmeldung „#{allocation}“ wurden verteilt +AllocationResultsLecturer: Es wurden Plätze zugewiesen, wie folgt: +AllocationResultLecturer csh@CourseShorthand count@Int64: #{count} Teilnehmer für #{csh} +AllocationResultsStudent: Sie haben Plätze erhalten in: +AllocationNoResultsStudent: Sie haben leider keine Plätze erhalten. +AllocationResultStudent csh@CourseShorthand: Sie haben einen Platz in #{csh} erhalten. + +FavouriteVisited: Kürzlich besucht +FavouriteParticipant: Ihre Kurse +FavouriteManual: Favoriten +FavouriteCurrent: Aktueller Kurs diff --git a/models/allocations b/models/allocations.model similarity index 95% rename from models/allocations rename to models/allocations.model index 9ddbd59bd..8f0805b34 100644 --- a/models/allocations +++ b/models/allocations.model @@ -21,6 +21,8 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never -- overrideVisible not needed, since courses are always visible + fingerprint AllocationFingerprint Maybe + matchingLog FileId Maybe TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester deriving Show Eq Ord Generic @@ -35,6 +37,7 @@ AllocationUser allocation AllocationId user UserId totalCourses Natural -- number of total allocated courses for this user must be <= than this number + priority AllocationPriority Maybe UniqueAllocationUser allocation user AllocationDeregister -- self-inflicted user-deregistrations from an allocated course diff --git a/models/audit b/models/audit.model similarity index 100% rename from models/audit rename to models/audit.model diff --git a/models/config b/models/config.model similarity index 100% rename from models/config rename to models/config.model diff --git a/models/courses b/models/courses.model similarity index 77% rename from models/courses rename to models/courses.model index 260c4254f..680d0d7dd 100644 --- a/models/courses +++ b/models/courses.model @@ -35,12 +35,6 @@ CourseEdit -- who edited when a row in table "Course", kept indef user UserId time UTCTime course CourseId -CourseFavourite -- which user accessed which course when, only displayed to user for convenience; - user UserId -- max number of rows kept per user is user-defined by column 'maxFavourites' in table "User" - time UTCTime -- oldest is removed first - course CourseId - UniqueCourseFavourite user course - deriving Show Lecturer -- course ownership user UserId course CourseId @@ -51,7 +45,7 @@ CourseParticipant -- course enrolement user UserId registration UTCTime -- time of last enrolement for this course field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades - allocated Bool default=false -- participant was centrally allocated + allocated AllocationId Maybe -- participant was centrally allocated UniqueParticipant user course -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student @@ -76,20 +70,3 @@ CourseUserExamOfficeOptOut user UserId school SchoolId UniqueCourseUserExamOfficeOptOut course user school - -CourseApplication - course CourseId - user UserId - field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades - text Text Maybe -- free text entered by user - ratingVeto Bool default=false - ratingPoints ExamGrade Maybe - ratingComment Text Maybe - allocation AllocationId Maybe - allocationPriority Natural Maybe - time UTCTime default=now() - ratingTime UTCTime Maybe -CourseApplicationFile - application CourseApplicationId - file FileId - UniqueApplicationFile application file \ No newline at end of file diff --git a/models/courses/applications.model b/models/courses/applications.model new file mode 100644 index 000000000..d1d3a4876 --- /dev/null +++ b/models/courses/applications.model @@ -0,0 +1,16 @@ +CourseApplication + course CourseId + user UserId + field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades + text Text Maybe -- free text entered by user + ratingVeto Bool default=false + ratingPoints ExamGrade Maybe + ratingComment Text Maybe + allocation AllocationId Maybe + allocationPriority Natural Maybe + time UTCTime default=now() + ratingTime UTCTime Maybe +CourseApplicationFile + application CourseApplicationId + file FileId + UniqueApplicationFile application file diff --git a/models/courses/favourite.model b/models/courses/favourite.model new file mode 100644 index 000000000..1c5077b77 --- /dev/null +++ b/models/courses/favourite.model @@ -0,0 +1,10 @@ +CourseFavourite -- which user accessed which course when, only displayed to user for convenience; + user UserId + course CourseId + reason FavouriteReason + lastVisit UTCTime + UniqueCourseFavourite user course +CourseNoFavourite + user UserId + course CourseId + UniqueCourseNoFavourite user course \ No newline at end of file diff --git a/models/materials b/models/courses/materials.model similarity index 89% rename from models/materials rename to models/courses/materials.model index 01076a1cf..b8d321fc3 100644 --- a/models/materials +++ b/models/courses/materials.model @@ -9,4 +9,5 @@ Material -- course material for disemination to course participants deriving Generic MaterialFile -- a file that is part of a material distribution material MaterialId - file FileId \ No newline at end of file + file FileId + UniqueMaterialFile material file \ No newline at end of file diff --git a/models/courses/news.model b/models/courses/news.model new file mode 100644 index 000000000..8596d0930 --- /dev/null +++ b/models/courses/news.model @@ -0,0 +1,12 @@ +CourseNews + course CourseId + visibleFrom UTCTime Maybe + participantsOnly Bool + title Text Maybe + content Html + summary Html Maybe + lastEdit UTCTime +CourseNewsFile + news CourseNewsId + file FileId + UniqueCourseNewsFile news file \ No newline at end of file diff --git a/models/exam-office b/models/exam-office.model similarity index 100% rename from models/exam-office rename to models/exam-office.model diff --git a/models/exams b/models/exams.model similarity index 100% rename from models/exams rename to models/exams.model diff --git a/models/files b/models/files.model similarity index 100% rename from models/files rename to models/files.model diff --git a/models/invitations b/models/invitations.model similarity index 100% rename from models/invitations rename to models/invitations.model diff --git a/models/jobs b/models/jobs.model similarity index 100% rename from models/jobs rename to models/jobs.model diff --git a/models/schools b/models/schools.model similarity index 100% rename from models/schools rename to models/schools.model diff --git a/models/sheets b/models/sheets.model similarity index 100% rename from models/sheets rename to models/sheets.model diff --git a/models/submissions b/models/submissions.model similarity index 100% rename from models/submissions rename to models/submissions.model diff --git a/models/system-messages b/models/system-messages.model similarity index 100% rename from models/system-messages rename to models/system-messages.model diff --git a/models/terms b/models/terms.model similarity index 100% rename from models/terms rename to models/terms.model diff --git a/models/tutorials b/models/tutorials.model similarity index 100% rename from models/tutorials rename to models/tutorials.model diff --git a/models/users b/models/users.model similarity index 96% rename from models/users rename to models/users.model index 14c0ddc2e..86fa7fd9f 100644 --- a/models/users +++ b/models/users.model @@ -21,7 +21,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) firstName Text -- For export in tables, pre-split firstName from displayName title Text Maybe -- For upcoming name customisation - maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined + maxFavourites Int default=12 -- max number of non-manual entries in favourites bar (pruned only if below a set importance threshold) + maxFavouriteTerms Int default=2 -- max number of term-sections in favourites bar theme Theme default='Default' -- Color-theme of the frontend; user-defined dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined dateFormat DateTimeFormat "default='%d.%m.%Y'" -- preferred Date-only display format for user; user-defined diff --git a/package-lock.json b/package-lock.json index e159c21a4..cdd996e32 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.2", + "version": "7.9.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 9d2dd5e34..4290e3563 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "7.3.2", + "version": "7.9.1", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 9b0b96354..12f356c32 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 7.3.2 +version: 7.9.1 dependencies: - base >=4.9.1.0 && <5 @@ -138,6 +138,8 @@ dependencies: - deepseq - multiset - retry + - generic-lens + - array other-extensions: - GeneralizedNewtypeDeriving @@ -202,6 +204,7 @@ ghc-options: - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - -j + - -freduction-depth=0 when: - condition: flag(pedantic) diff --git a/routes b/routes index f056b1f98..944e20502 100644 --- a/routes +++ b/routes @@ -104,7 +104,8 @@ !/course/new CourseNewR GET POST !lecturer /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free - /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬exam-result !lecturerANDallocation-time + /favourite CFavouriteR POST + /register CRegisterR GET POST !timeANDcapacityANDallocation-timeAND¬course-registered !timeANDallocation-timeAND¬exam-resultANDcourse-registered !lecturerANDallocation-time /register-template CRegisterTemplateR GET !free /edit CEditR GET POST /lecturer-invite CLecInviteR GET POST @@ -179,6 +180,13 @@ /apps/#CryptoFileNameCourseApplication CourseApplicationR: / CAEditR GET POST !timeANDself !lecturerANDstaff-time !selfANDread /files CAFilesR GET !self !lecturerANDstaff-time + !/news/add CNewsNewR GET POST + /news/#CryptoUUIDCourseNews CourseNewsR: + / CNShowR GET !timeANDparticipant + /edit CNEditR GET POST + /delete CNDeleteR GET POST + !/download CNArchiveR GET !timeANDparticipant + !/download/*FilePath CNFileR GET !timeANDparticipant /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 0f1296887..35ec7af50 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -48,6 +48,7 @@ decCryptoIDs [ ''SubmissionId , ''AllocationId , ''CourseApplicationId , ''CourseId + , ''CourseNewsId ] -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission" diff --git a/src/Foundation.hs b/src/Foundation.hs index e3de692ef..a878daacb 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -156,8 +156,20 @@ deriving instance Generic CourseApplicationR deriving instance Generic AllocationR deriving instance Generic SchoolR deriving instance Generic ExamOfficeR +deriving instance Generic CourseNewsR deriving instance Generic (Route UniWorX) +data RouteChildren +type instance Children RouteChildren a = ChildrenRouteChildren a +type family ChildrenRouteChildren a where + ChildrenRouteChildren (Route EmbeddedStatic) = '[] + ChildrenRouteChildren (Route Auth) = '[] + ChildrenRouteChildren UUID = '[] + ChildrenRouteChildren (Key a) = '[] + ChildrenRouteChildren (CI a) = '[] + + ChildrenRouteChildren a = Children ChGeneric a + -- | Convenient Type Synonyms: type DB = YesodDB UniWorX type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, Widget) @@ -188,6 +200,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn pattern CApplicationR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> CourseApplicationR -> Route UniWorX pattern CApplicationR tid ssh csh appId ptn = CourseR tid ssh csh (CourseApplicationR appId ptn) + +pattern CNewsR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> CourseNewsR -> Route UniWorX +pattern CNewsR tid ssh csh nId ptn + = CourseR tid ssh csh (CourseNewsR nId ptn) pluralDE :: (Eq a, Num a) @@ -317,6 +333,7 @@ embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel embedRenderMessage ''UniWorX ''SchoolFunction id embedRenderMessage ''UniWorX ''CsvPreset id embedRenderMessage ''UniWorX ''Quoting ("Csv" <>) +embedRenderMessage ''UniWorX ''FavouriteReason id embedRenderMessage ''UniWorX ''AuthenticationMode id @@ -934,6 +951,13 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of && NTop systemMessageTo >= cTime return Authorized + CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do + nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId + cTime <- (NTop . Just) <$> liftIO getCurrentTime + guard $ NTop courseNewsVisibleFrom <= cTime + return Authorized + r -> $unsupportedAuthPredicate AuthTime r tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do @@ -985,8 +1009,8 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of mba <- mbAllocation tid ssh csh case mba of Just (_, Allocation{..}) - | NTop allocationStaffRegisterTo <= NTop (Just now) - || NTop allocationStaffRegisterFrom >= NTop (Just now) + | NTop allocationRegisterByStaffTo <= NTop (Just now) + || NTop allocationRegisterByStaffFrom >= NTop (Just now) -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister _other -> return Authorized @@ -995,7 +1019,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of mba <- mbAllocation tid ssh csh case mba of Just (_, Allocation{..}) - | NTop allocationRegisterByStaffTo <= NTop (Just now) + | NTop allocationRegisterByStaffTo <= NTop (Just now) || NTop allocationRegisterByStaffFrom >= NTop (Just now) -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete _other -> return Authorized @@ -1104,81 +1128,96 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid return Authorized r -> $unsupportedAuthPredicate AuthAllocationRegistered r -tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of - CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do - cTime <- liftIO getCurrentTime - let - authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () - authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from - participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID - -- participant is currently registered - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do - E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse - E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant has at least one submission - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do - E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission - E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is member of a submissionGroup - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do - E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup - E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse - E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a sheet corrector - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do - E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is a tutorial user - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do - E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is tutor for this course - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do - E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial - E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse - E.where_ $ tutor E.^. TutorUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is lecturer for this course - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do - E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse - E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - -- participant is applicant for this course - $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do - E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation - E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse - E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant - E.&&. course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseSchool E.==. E.val ssh - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom) - E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo) +tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of + CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsParticipant) $ do + nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID + CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId + if | courseNewsParticipantsOnly -> do + uid <- hoistMaybe mAuthId + exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid + | otherwise + -> return Authorized + CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do + participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID + isCourseParticipant tid ssh csh participant unauthorizedI MsgUnauthorizedParticipant + r -> $unsupportedAuthPredicate AuthParticipant r + + where + isCourseParticipant tid ssh csh participant = do + cTime <- liftIO getCurrentTime + let + authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB () + authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from + -- participant is currently registered + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do + E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse + E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant has at least one submission + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do + E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission + E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is member of a submissionGroup + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do + E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup + E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse + E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is a sheet corrector + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do + E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is a tutorial user + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is tutor for this course + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do + E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial + E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse + E.where_ $ tutor E.^. TutorUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is lecturer for this course + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + -- participant is applicant for this course + $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do + E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation + E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse + E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.where_ $ E.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom) + E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo) + + return () tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -1484,24 +1523,22 @@ instance Yesod UniWorX where now <- liftIO $ getCurrentTime uid <- MaybeT $ liftHandler maybeAuthId cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - user <- MaybeT $ get uid - let courseFavourite = CourseFavourite uid now cid + User{userMaxFavourites} <- MaybeT $ get uid - $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] -- update Favourites void . lift $ upsertBy (UniqueCourseFavourite uid cid) - courseFavourite - [CourseFavouriteTime =. now] + (CourseFavourite uid cid FavouriteVisited now) + [CourseFavouriteLastVisit =. now] -- prune Favourites to user-defined size - oldFavs <- lift $ selectKeysList - [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy $ userMaxFavourites user - ] - lift . forM_ oldFavs $ \fav -> do - $logDebugS "updateFavourites" "Deleting old favourite." - delete fav + oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] [] + let deleteFavs = oldFavs + & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal) + & drop userMaxFavourites + & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal) + & map entityKey + unless (null deleteFavs) $ + lift $ deleteWhere [CourseFavouriteId <-. deleteFavs] _other -> return () normalizeRouteMiddleware :: Handler a -> Handler a normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do @@ -1648,24 +1685,61 @@ siteLayout' headingOverride widget = do isAuth <- isJust <$> maybeAuthId - -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! - (favourites', currentTheme) <- do + -- Lookup Favourites & Theme if possible + (favourites', maxFavouriteTerms, currentTheme) <- do muid <- maybeAuthPair - case muid of - Nothing -> return ([],userDefaultTheme) - (Just (uid,user)) -> do - favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - return course - return (favs, userTheme user) - favourites <- forM favourites' $ \(Entity _ c@Course{..}) + + favCourses <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do + E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse + E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid) + + let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId + isCurrent + | Just (CourseR tid ssh csh _) <- mcurrentRoute + = course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + | otherwise + = E.false + notBlacklist = E.not_ . E.exists . E.from $ \courseNoFavourite -> + E.where_ $ E.just (courseNoFavourite E.^. CourseNoFavouriteUser) E.==. E.val (view _1 <$> muid) + E.&&. courseNoFavourite E.^. CourseNoFavouriteCourse E.==. course E.^. CourseId + isParticipant = E.exists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.&&. E.just (participant E.^. CourseParticipantUser) E.==. E.val (view _1 <$> muid) + isLecturer = E.exists . E.from $ \lecturer -> + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. E.just (lecturer E.^. LecturerUser) E.==. E.val (view _1 <$> muid) + isCorrector = E.exists . E.from $ \(corrector `E.InnerJoin` sheet) -> do + E.on $ corrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + E.&&. sheet E.^. SheetCourse E.==. course E.^. CourseId + E.where_ $ E.just (corrector E.^. SheetCorrectorUser) E.==. E.val (view _1 <$> muid) + isTutor = E.exists . E.from $ \(tutor `E.InnerJoin` tutorial) -> do + E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId + E.&&. tutorial E.^. TutorialCourse E.==. course E.^. CourseId + E.where_ $ E.just (tutor E.^. TutorUser) E.==. E.val (view _1 <$> muid) + isAssociated = isParticipant E.||. isLecturer E.||. isCorrector E.||. isTutor + + reason = E.case_ + [ E.when_ isCurrent E.then_ . E.just $ E.val FavouriteCurrent + , E.when_ isAssociated E.then_ . E.just $ E.val FavouriteParticipant + ] (E.else_ $ courseFavourite E.?. CourseFavouriteReason) + + E.where_ $ ((isFavourite E.||. isAssociated) E.&&. notBlacklist) E.||. isCurrent + + return (course, reason) + + return ( favCourses + , maybe userDefaultMaxFavouriteTerms userMaxFavouriteTerms $ view _2 <$> muid + , maybe userDefaultTheme userTheme $ view _2 <$> muid + ) + favourites <- forM favourites' $ \(Entity _ c@Course{..}, E.Value mFavourite) -> let courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR + favouriteReason = fromMaybe FavouriteCurrent mFavourite in do items <- filterM menuItemAccessCallback (pageActions courseRoute) items' <- forM items $ \i -> (i, ) <$> toTextUrl i - return (c, courseRoute, items') + return (c, courseRoute, items', favouriteReason) mmsgs <- if | isModal -> getMessages @@ -1682,9 +1756,11 @@ siteLayout' headingOverride widget = do highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs in \r -> Just r == highR favouriteTerms :: [TermIdentifier] - favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites - favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])] - favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites + favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites + favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(MenuItem, Text)], FavouriteReason)] + favouriteTermReason tid favReason' = favourites + & filter (\(Course{..}, _, _, favReason) -> unTermKey courseTerm == tid && favReason == favReason') + & sortOn (\(Course{..}, _, _, _) -> courseName) -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and @@ -1848,6 +1924,11 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CourseR tid ssh csh CNewsNewR) = return ("Neue Nachricht", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CNewsR tid ssh csh _ CNShowR) = return ("Kursnachricht" , Just $ CourseR tid ssh csh CShowR) + breadcrumb (CNewsR tid ssh csh cID CNEditR) = return ("Bearbeiten" , Just $ CNewsR tid ssh csh cID CNShowR) + breadcrumb (CNewsR tid ssh csh cID CNDeleteR) = return ("Löschen" , Just $ CNewsR tid ssh csh cID CNShowR) + breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) @@ -3135,12 +3216,18 @@ routeNormalizers :: [Route UniWorX -> WriterT Any DB (Route UniWorX)] routeNormalizers = [ normalizeRender , ncSchool + , ncAllocation , ncCourse , ncSheet + , ncMaterial + , ncTutorial + , ncExam , verifySubmission , verifyCourseApplication + , verifyCourseNews ] where + normalizeRender :: Route UniWorX -> WriterT Any DB (Route UniWorX) normalizeRender route = route <$ do YesodRequest{..} <- liftHandler getRequest let original = (W.pathInfo reqWaiRequest, reqGetParams) @@ -3151,37 +3238,64 @@ routeNormalizers = | otherwise -> do $logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|] tell $ Any True + + maybeOrig :: (Route UniWorX -> MaybeT (WriterT Any DB) (Route UniWorX)) + -> Route UniWorX -> WriterT Any DB (Route UniWorX) maybeOrig f route = maybeT (return route) $ f route - hasChanged a b + + caseChanged :: (Eq a, Show a) => CI a -> CI a -> MaybeT (WriterT Any DB) () + caseChanged a b | ((/=) `on` original) a b = do $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | otherwise = return () - ncSchool = maybeOrig $ \route -> do - TermSchoolCourseListR tid ssh <- return route + + ncSchool = maybeOrig . typesUsing @RouteChildren @SchoolId $ \ssh -> $cachedHereBinary ssh $ do let schoolShort :: SchoolShorthand schoolShort = unSchoolKey ssh Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort - (hasChanged `on` unSchoolKey)ssh ssh' - return $ TermSchoolCourseListR tid ssh' + (caseChanged `on` unSchoolKey) ssh ssh' + return ssh' + ncAllocation = maybeOrig $ \route -> do + AllocationR tid ssh ash _ <- return route + Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . lift . getBy $ TermSchoolAllocationShort tid ssh ash + caseChanged ash allocationShorthand + return $ route & typesUsing @RouteChildren @AllocationShorthand . filtered (== ash) .~ allocationShorthand ncCourse = maybeOrig $ \route -> do - CourseR tid ssh csh subRoute <- return route - Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - hasChanged csh courseShorthand - (hasChanged `on` unSchoolKey) ssh courseSchool - return $ CourseR tid courseSchool courseShorthand subRoute + CourseR tid ssh csh _ <- return route + Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + caseChanged csh courseShorthand + return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand ncSheet = maybeOrig $ \route -> do - CSheetR tid ssh csh shn subRoute <- return route - Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn - hasChanged shn sheetName - return $ CSheetR tid ssh csh sheetName subRoute + CSheetR tid ssh csh shn _ <- return route + Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn + caseChanged shn sheetName + return $ route & typesUsing @RouteChildren @SheetName . filtered (== shn) .~ sheetName + ncMaterial = maybeOrig $ \route -> do + CMaterialR tid ssh csh mnm _ <- return route + Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Material{..} <- MaybeT . $cachedHereBinary (cid, mnm) . lift . getBy $ UniqueMaterial cid mnm + caseChanged mnm materialName + return $ route & typesUsing @RouteChildren @MaterialName . filtered (== mnm) .~ materialName + ncTutorial = maybeOrig $ \route -> do + CTutorialR tid ssh csh tutn _ <- return route + Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Tutorial{..} <- MaybeT . $cachedHereBinary (cid, tutn) . lift . getBy $ UniqueTutorial cid tutn + caseChanged tutn tutorialName + return $ route & typesUsing @RouteChildren @TutorialName . filtered (== tutn) .~ tutorialName + ncExam = maybeOrig $ \route -> do + CExamR tid ssh csh examn _ <- return route + Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh + Entity _ Exam{..} <- MaybeT . $cachedHereBinary (cid, examn) . lift . getBy $ UniqueExam cid examn + caseChanged examn examName + return $ route & typesUsing @RouteChildren @ExamName . filtered (== examn) .~ examName verifySubmission = maybeOrig $ \route -> do CSubmissionR _tid _ssh _csh _shn cID sr <- return route - sId <- decrypt cID - Submission{submissionSheet} <- lift . lift $ get404 sId - Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet - Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse + sId <- $cachedHereBinary cID $ decrypt cID + Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId + Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet + Course{courseTerm, courseSchool, courseShorthand} <- MaybeT . $cachedHereBinary sheetCourse . lift $ get sheetCourse let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr tell . Any $ route /= newRoute return newRoute @@ -3193,6 +3307,14 @@ routeNormalizers = let newRoute = CApplicationR courseTerm courseSchool courseShorthand cID sr tell . Any $ route /= newRoute return newRoute + verifyCourseNews = maybeOrig $ \route -> do + CNewsR _tid _ssh _csh cID sr <- return route + aId <- decrypt cID + CourseNews{courseNewsCourse} <- lift . lift $ get404 aId + Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 courseNewsCourse + let newRoute = CNewsR courseTerm courseSchool courseShorthand cID sr + tell . Any $ route /= newRoute + return newRoute -- How to run database actions. @@ -3202,7 +3324,9 @@ instance YesodPersist UniWorX where $logDebugS "YesodPersist" "runDB" runSqlPool action =<< appConnPool <$> getYesod instance YesodPersistRunner UniWorX where - getDBRunner = defaultGetDBRunner appConnPool + getDBRunner = do + (DBRunner{..}, cleanup) <- defaultGetDBRunner appConnPool + return . (, cleanup) $ DBRunner (\act -> $logDebugS "YesodPersist" "runDBRunner" >> runDBRunner act) data CampusUserConversionException = CampusUserInvalidEmail @@ -3281,6 +3405,7 @@ upsertCampusUser ldapData Creds{..} = do newUser = User { userIdent = mk credsIdent , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , userTheme = userDefaultTheme , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index eb5e55255..c502ab48a 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do { allocationUserAllocation = aId , allocationUserUser = uid , allocationUserTotalCourses = arfTotalCourses + , allocationUserPriority = Nothing } [ AllocationUserTotalCourses =. arfTotalCourses ] diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index 3d366d129..5d0adf9de 100644 --- a/src/Handler/Allocation/Show.hs +++ b/src/Handler/Allocation/Show.hs @@ -23,11 +23,16 @@ getAShowR tid ssh ash = do resultCourseApplication = _2 . _Just resultHasTemplate :: Simple Field3 a (E.Value Bool) => Lens' a Bool resultHasTemplate = _3 . _Value + resultIsRegistered :: Simple Field4 a (E.Value Bool) => Lens' a Bool + resultIsRegistered = _4 . _Value - (Entity aId Allocation{..}, courses, registration) <- runDB $ do - alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash + (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do + alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash + school <- getJust allocationSchool - courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication) -> do + courses <- E.select . E.from $ \((allocationCourse `E.InnerJoin` course) `E.LeftOuterJoin` courseApplication `E.LeftOuterJoin` registration) -> do + E.on $ registration E.?. CourseParticipantCourse E.==. E.just (course E.^. CourseId) + E.&&. registration E.?. CourseParticipantUser E.==. E.val muid E.on $ courseApplication E.?. CourseApplicationCourse E.==. E.just (course E.^. CourseId) E.&&. courseApplication E.?. CourseApplicationUser E.==. E.val muid E.&&. courseApplication E.?. CourseApplicationAllocation E.==. E.just (E.just $ E.val aId) @@ -36,11 +41,13 @@ getAShowR tid ssh ash = do E.orderBy [E.asc $ course E.^. CourseName] let hasTemplate = E.exists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. course E.^. CourseId - return (course, courseApplication, hasTemplate) + return (course, courseApplication, hasTemplate, E.not_ . E.isNothing $ registration E.?. CourseParticipantId) registration <- fmap join . for muid $ getBy . UniqueAllocationUser aId - return (alloc, nubOn (view $ resultCourse . _entityKey) courses, registration) + isAnyLecturer <- hasWriteAccessTo CourseNewR + + return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration) MsgRenderer mr <- getMsgRenderer let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName @@ -68,6 +75,7 @@ getAShowR tid ssh ash = do let Entity cid Course{..} = cEntry ^. resultCourse hasApplicationTemplate = cEntry ^. resultHasTemplate mApp = cEntry ^? resultCourseApplication + isRegistered = cEntry ^. resultIsRegistered cID <- encrypt cid :: WidgetFor UniWorX CryptoUUIDCourse mayApply <- hasWriteAccessTo . AllocationR tid ssh ash $ AApplyR cID isLecturer <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CEditR diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 241aba4cf..454e11c85 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -17,6 +17,7 @@ import Handler.Course.User as Handler.Course import Handler.Course.Users as Handler.Course import Handler.Course.Application as Handler.Course import Handler.ExamOffice.Course as Handler.Course +import Handler.Course.News as Handler.Course getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -28,3 +29,6 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = postCNotesR postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] + +postCFavouriteR :: TermId -> SchoolId -> CourseShorthand -> Handler () +postCFavouriteR _ _ _ = error "not implemented" diff --git a/src/Handler/Course/News.hs b/src/Handler/Course/News.hs new file mode 100644 index 000000000..640e4b242 --- /dev/null +++ b/src/Handler/Course/News.hs @@ -0,0 +1,9 @@ +module Handler.Course.News + ( module Handler.Course.News + ) where + +import Handler.Course.News.New as Handler.Course.News +import Handler.Course.News.Edit as Handler.Course.News +import Handler.Course.News.Download as Handler.Course.News +import Handler.Course.News.Show as Handler.Course.News +import Handler.Course.News.Delete as Handler.Course.News diff --git a/src/Handler/Course/News/Delete.hs b/src/Handler/Course/News/Delete.hs new file mode 100644 index 000000000..88bc72d90 --- /dev/null +++ b/src/Handler/Course/News/Delete.hs @@ -0,0 +1,44 @@ +module Handler.Course.News.Delete + ( getCNDeleteR, postCNDeleteR + ) where + +import Import +import Handler.Utils.Delete + +import qualified Data.Set as Set + + +getCNDeleteR, postCNDeleteR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html +getCNDeleteR = postCNDeleteR +postCNDeleteR tid ssh csh cID = do + nId <- decrypt cID + + let + drRecords :: Set (Key CourseNews) + drRecords = Set.singleton nId + + drGetInfo = return + drUnjoin = id + + drRenderRecord :: Entity CourseNews -> DB Widget + drRenderRecord (Entity _ CourseNews{..}) + = return . fromMaybe (toWidget courseNewsContent) $ asum + [ toWidget <$> courseNewsTitle + , toWidget <$> courseNewsSummary + ] + + drRecordConfirmString :: Entity CourseNews -> DB Text + drRecordConfirmString _ = return "" + + drCaption, drSuccessMessage :: SomeMessage UniWorX + drCaption = SomeMessage MsgCourseNewsDeleteQuestion + drSuccessMessage = SomeMessage MsgCourseNewsDeleted + + drAbort, drSuccess :: SomeRoute UniWorX + drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] + drSuccess = SomeRoute $ CourseR tid ssh csh CShowR + + drDelete :: forall a. CourseNewsId -> DB a -> DB a + drDelete _ = id + + deleteR DeleteRoute{..} diff --git a/src/Handler/Course/News/Download.hs b/src/Handler/Course/News/Download.hs new file mode 100644 index 000000000..f83244ce8 --- /dev/null +++ b/src/Handler/Course/News/Download.hs @@ -0,0 +1,41 @@ +module Handler.Course.News.Download + ( getCNArchiveR + , getCNFileR + ) where + +import Import +import Handler.Utils + +import qualified Database.Esqueleto as E + +import qualified Data.Conduit.List as C + + +getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent +getCNArchiveR tid ssh csh cID = do + nId <- decrypt cID + CourseNews{..} <- runDB $ get404 nId + + archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle) + + let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $ + \(newsFile `E.InnerJoin` file) -> do + E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + return file + + serveSomeFiles archiveName getFilesQuery + + +getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent +getCNFileR _ _ _ cID title = do + nId <- decrypt cID + + let + fileQuery = E.selectSource . E.from $ \(newsFile `E.InnerJoin` file) -> do + E.on $ newsFile E.^. CourseNewsFileFile E.==. file E.^. FileId + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + E.&&. file E.^. FileTitle E.==. E.val title + return file + + serveOneFile $ fileQuery .| C.map entityVal diff --git a/src/Handler/Course/News/Edit.hs b/src/Handler/Course/News/Edit.hs new file mode 100644 index 000000000..af701c4ca --- /dev/null +++ b/src/Handler/Course/News/Edit.hs @@ -0,0 +1,54 @@ +module Handler.Course.News.Edit + ( getCNEditR, postCNEditR + ) where + +import Import +import Handler.Utils + +import Handler.Course.News.Form + +import qualified Data.Set as Set + +import qualified Data.Conduit.List as C + + +getCNEditR, postCNEditR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html +getCNEditR = postCNEditR +postCNEditR tid ssh csh cID = do + nId <- decrypt cID + (courseNews@CourseNews{..}, fids) <- runDB $ do + courseNews <- get404 nId + cnfs <- selectList [CourseNewsFileNews ==. nId] [] + return ( courseNews + , setOf (folded . _entityVal . _courseNewsFileFile) cnfs + ) + + ((newsRes, newsWgt'), newsEnctype) <- runFormPost . courseNewsForm . Just $ courseNewsToForm courseNews fids + + formResult newsRes $ \CourseNewsForm{..} -> do + now <- liftIO getCurrentTime + runDB $ do + replace nId CourseNews + { courseNewsCourse + , courseNewsVisibleFrom = cnfVisibleFrom + , courseNewsParticipantsOnly = cnfParticipantsOnly + , courseNewsTitle = cnfTitle + , courseNewsContent = cnfContent + , courseNewsSummary = cnfSummary + , courseNewsLastEdit = now + } + let + insertFile (Left fId) = fId <$ upsertBy (UniqueCourseNewsFile nId fId) (CourseNewsFile nId fId) [] + insertFile (Right f ) = insert f >>= \fId -> fId <$ insert_ (CourseNewsFile nId fId) + newFids <- runConduit $ transPipe lift (fromMaybe (return ()) cnfFiles) .| C.mapM insertFile .| C.foldMap Set.singleton + deleteWhere [ CourseNewsFileNews ==. nId, CourseNewsFileFile /<-. Set.toList newFids ] + addMessageI Success MsgCourseNewsEdited + redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] + + siteLayoutMsg MsgMenuCourseNewsEdit $ do + setTitleI MsgMenuCourseNewsEdit + + wrapForm newsWgt' def + { formAction = Just . SomeRoute $ CNewsR tid ssh csh cID CNEditR + , formEncoding = newsEnctype + } diff --git a/src/Handler/Course/News/Form.hs b/src/Handler/Course/News/Form.hs new file mode 100644 index 000000000..eb4edaf0a --- /dev/null +++ b/src/Handler/Course/News/Form.hs @@ -0,0 +1,71 @@ +module Handler.Course.News.Form + ( CourseNewsForm(..) + , courseNewsForm + , courseNewsToForm + ) where + +import Import +import Handler.Utils + +import Text.Blaze.Renderer.Text (renderMarkup) + +import qualified Data.Conduit.List as C + +import qualified Data.Set as Set + + +data CourseNewsForm = CourseNewsForm + { cnfTitle :: Maybe Text + , cnfSummary :: Maybe Html + , cnfContent :: Html + , cnfParticipantsOnly :: Bool + , cnfVisibleFrom :: Maybe UTCTime + , cnfFiles :: Maybe (ConduitT () (Either FileId File) Handler ()) + } + +courseNewsForm :: Maybe CourseNewsForm -> Form CourseNewsForm +courseNewsForm template = identifyForm FIDCourseNews . renderWForm FormStandard $ do + now <- liftIO getCurrentTime + + let oldFileIds = maybe (return mempty) (\s -> runConduit $ s .| C.foldMap (either opoint $ const mempty)) $ template >>= cnfFiles + cTime = ceilingQuarterHour now + visibleFromTip + | Just vFrom <- template >>= cnfVisibleFrom + , vFrom <= now + = MsgCourseNewsVisibleFromEditWarning + | otherwise + = MsgCourseNewsVisibleFromTip + + cnfTitle' <- wopt + (textField & cfStrip & guardField (not . null)) + (fslI MsgCourseNewsTitle) + (cnfTitle <$> template) + cnfSummary' <- wopt + (htmlField & guardField (not . null . renderMarkup)) + (fslI MsgCourseNewsSummary & setTooltip MsgCourseNewsSummaryTip) + (cnfSummary <$> template) + cnfContent' <- wreq + (htmlField & guardField (not . null . renderMarkup)) + (fslI MsgCourseNewsContent) + (cnfContent <$> template) + cnfParticipantsOnly' <- wpopt checkBoxField (fslI MsgCourseNewsParticipantsOnly) (cnfParticipantsOnly <$> template) + cnfVisibleFrom' <- wopt utcTimeField (fslI MsgCourseNewsVisibleFrom & setTooltip visibleFromTip) (cnfVisibleFrom <$> template <|> Just (Just cTime)) + cnfFiles' <- wopt (multiFileField oldFileIds) (fslI MsgCourseNewsFiles) (cnfFiles <$> template) + + return $ CourseNewsForm + <$> cnfTitle' + <*> cnfSummary' + <*> cnfContent' + <*> cnfParticipantsOnly' + <*> cnfVisibleFrom' + <*> cnfFiles' + +courseNewsToForm :: CourseNews -> Set FileId -> CourseNewsForm +courseNewsToForm CourseNews{..} fs = CourseNewsForm + { cnfTitle = courseNewsTitle + , cnfSummary = courseNewsSummary + , cnfContent = courseNewsContent + , cnfParticipantsOnly = courseNewsParticipantsOnly + , cnfVisibleFrom = courseNewsVisibleFrom + , cnfFiles = guardOn (not $ Set.null fs) $ C.sourceList (Left <$> Set.toList fs) + } diff --git a/src/Handler/Course/News/New.hs b/src/Handler/Course/News/New.hs new file mode 100644 index 000000000..c6b2f10be --- /dev/null +++ b/src/Handler/Course/News/New.hs @@ -0,0 +1,47 @@ +module Handler.Course.News.New + ( getCNewsNewR, postCNewsNewR + ) where + +import Import +import Handler.Utils + +import Handler.Course.News.Form + +import qualified Data.Conduit.List as C + + +getCNewsNewR, postCNewsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCNewsNewR = postCNewsNewR +postCNewsNewR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + ((newsRes, newsWgt'), newsEnctype) <- runFormPost $ courseNewsForm Nothing + + formResult newsRes $ \CourseNewsForm{..} -> do + now <- liftIO getCurrentTime + cID <- runDB $ do + nId <- insert CourseNews + { courseNewsCourse = cid + , courseNewsVisibleFrom = cnfVisibleFrom + , courseNewsParticipantsOnly = cnfParticipantsOnly + , courseNewsTitle = cnfTitle + , courseNewsContent = cnfContent + , courseNewsSummary = cnfSummary + , courseNewsLastEdit = now + } + let + insertFile (Left fId) = insert_ $ CourseNewsFile nId fId + insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f + forM_ cnfFiles $ \fSource -> + runConduit $ transPipe lift fSource .| C.mapM_ insertFile + encrypt nId :: DB CryptoUUIDCourseNews + addMessageI Success MsgCourseNewsCreated + redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|] + + siteLayoutMsg MsgMenuCourseNewsNew $ do + setTitleI MsgMenuCourseNewsNew + + wrapForm newsWgt' def + { formAction = Just . SomeRoute $ CourseR tid ssh csh CNewsNewR + , formEncoding = newsEnctype + } diff --git a/src/Handler/Course/News/Show.hs b/src/Handler/Course/News/Show.hs new file mode 100644 index 000000000..9fb4f81b1 --- /dev/null +++ b/src/Handler/Course/News/Show.hs @@ -0,0 +1,17 @@ +module Handler.Course.News.Show + ( getCNShowR + ) where + +import Import +import Handler.Utils + + +getCNShowR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler Html +getCNShowR tid ssh csh cID = do + nId <- decrypt cID + CourseNews{..} <- runDB $ get404 nId + + siteLayout' (toWidget <$> courseNewsTitle) $ do + setTitleI . prependCourseTitle tid ssh csh $ maybe (SomeMessage MsgCourseNews) SomeMessage courseNewsTitle + + $(widgetFile "course-news") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 9459346a3..fe9b96804 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where data InvitableJunction CourseParticipant = JunctionParticipant { jParticipantRegistration :: UTCTime , jParticipantField :: Maybe StudyFeaturesId - , jParticipantAllocated :: Bool + , jParticipantAllocated :: Maybe AllocationId } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData CourseParticipant = InvDBDataParticipant -- no data needed in DB to manage participant invitation @@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..} now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False + return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing invitationInsertHook _ _ CourseParticipant{..} _ act = do res <- act audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser @@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do void . lift . lift . insert $ CourseParticipant { courseParticipantCourse = cid , courseParticipantUser = uid - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index abef977ae..2e7b2fd45 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -141,6 +141,9 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do -> return $ FormSuccess Nothing | otherwise -> aFormToWForm $ fileUploadForm False (fslI . mkFs) courseApplicationsFiles + + when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $ + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationLog return $ CourseRegisterForm <$ secretRes @@ -197,7 +200,7 @@ postCRegisterR tid ssh csh = do = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid - insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False + insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing deleteApplications = do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] @@ -222,7 +225,7 @@ postCRegisterR tid ssh csh = do delete $ partId audit $ TransactionCourseParticipantDeleted cid uid - when courseParticipantAllocated $ do + when (is _Just courseParticipantAllocated) $ do now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index cdab9b549..4e474c6ac 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -18,7 +18,7 @@ import qualified Database.Esqueleto as E import Handler.Course.Register -import System.FilePath (addExtension) +import System.FilePath (addExtension, pathSeparator) import qualified Data.Conduit.List as C @@ -26,7 +26,7 @@ import qualified Data.Conduit.List as C getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) <- runDB . maybeT notFound $ do + (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -71,15 +71,31 @@ getCShowR tid ssh csh = do hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] [] - return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication) + news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ] + cTime <- NTop . Just <$> liftIO getCurrentTime + news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do + cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews + guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR + let visible = cTime >= NTop courseNewsVisibleFrom + files' <- lift . lift . E.select . E.from $ \(newsFile `E.InnerJoin` file) -> do + E.on $ file E.^. FileId E.==. newsFile E.^. CourseNewsFileFile + E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId + return (E.isNothing $ file E.^. FileContent, file E.^. FileTitle) + let files = files' + & over (mapped . _1) E.unValue + & over (mapped . _2) E.unValue + lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit + mayEdit <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR + mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR + return (cID, n, visible, files, lastEditText, mayEdit, mayDelete) + return (cid,course,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news) + + let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course + mDereg <- traverse (formatTime SelFormatDateTime) mDereg' - mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course - mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course - mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course - mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration cID <- encrypt cid :: Handler CryptoUUIDCourse - mAllocation' <- for mAllocation $ \Allocation{..} -> (,) - <$> pure allocationName + mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,) + <$> pure alloc <*> toTextUrl (AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID) regForm <- if | is _Just mbAid -> do @@ -236,6 +252,14 @@ getCShowR tid ssh csh = do & defaultSorting [SortAscBy "time"] (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable + let visibleNews = any (view _3) news + showNewsFiles fs = and + [ not $ null fs + , length fs <= 3 + , all (notElem pathSeparator . view _2) fs + ] + mayCreateNews <- hasWriteAccessTo $ CourseR tid ssh csh CNewsNewR + siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index bd222d966..abb8df144 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -118,31 +118,43 @@ postCUserR tid ssh csh uCId = do let regButton | is _Just mRegistration = BtnCourseDeregister | otherwise = BtnCourseRegister - ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton] + ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ + if | is _Just $ courseParticipantAllocated . entityVal =<< mRegistration + -> renderWForm FormStandard $ fmap (regButton, ) + <$ (wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip) + <*> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) + | otherwise + -> \csrf -> pure (FormSuccess (regButton, Nothing), toWidget csrf) let registrationButtonFrag :: Text registrationButtonFrag = "registration-button" - regButtonWidget = wrapForm regButtonView FormSettings + regButtonWidget = wrapForm' regButton regButtonView FormSettings { formMethod = POST , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag , formEncoding = regButtonEnctype , formAttrs = [] - , formSubmit = FormNoSubmit + , formSubmit = FormSubmit , formAnchor = Just registrationButtonFrag } formResult regButtonRes $ \case _ | not mayRegister -> permissionDenied "User may not be registered" - BtnCourseDeregister - | Just (Entity pId _) <- mRegistration + (BtnCourseDeregister, mbReason) + | Just (Entity pId CourseParticipant{..}) <- mRegistration -> do - runDB $ delete pId + runDB $ do + delete pId + audit $ TransactionCourseParticipantDeleted cid courseParticipantUser + + whenIsJust mbReason $ \reason -> do + now <- liftIO getCurrentTime + insert_ $ AllocationDeregister courseParticipantUser (Just cid) now (Just reason) addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk redirect $ CourseR tid ssh csh CUsersR | otherwise -> invalidArgs ["User not registered"] - BtnCourseRegister -> do + (BtnCourseRegister, _) -> do now <- liftIO getCurrentTime let field | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesValid) studies @@ -150,7 +162,7 @@ postCUserR tid ssh csh uCId = do | otherwise = Nothing pId <- runDB $ do - pId <- insertUnique $ CourseParticipant cid uid now field False + pId <- insertUnique $ CourseParticipant cid uid now field Nothing when (is _Just pId) $ audit $ TransactionCourseParticipantEdit cid uid return pId diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index df0169438..a89645a81 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -11,7 +11,6 @@ import Import import Utils.Form import Handler.Utils -import Database.Persist.Sql (deleteWhereCount) import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -126,18 +125,23 @@ instance Finite CourseUserAction nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''CourseUserAction id +data CourseUserActionData = CourseUserSendMailData + | CourseUserDeregisterData + { deregisterReason :: Maybe Text + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) -makeCourseUserTable :: forall h acts. + +makeCourseUserTable :: forall h act act'. ( Functor h, ToSortable h - , MonoFoldable acts - , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts) + , Ord act, PathPiece act, RenderMessage UniWorX act ) => CourseId - -> acts + -> Map act (AForm Handler act') -> (UserTableExpr -> E.SqlExpr (E.Value Bool)) - -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))) - -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData)) - -> DB (FormResult (Element acts, Set UserId), Widget) + -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))) + -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)) + -> DB (FormResult (act', Set UserId), Widget) makeCourseUserTable cid acts restrict colChoices psValidator = do currentRoute <- fromMaybe (error "makeCourseUserTable called from 404-handler") <$> liftHandler getCurrentRoute -- -- psValidator has default sorting and filtering @@ -209,7 +213,7 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do , dbParamsFormAdditional = renderAForm FormStandard $ (, mempty) . First . Just - <$> areq (selectField $ optionsF acts) (fslI MsgAction) Nothing + <$> multiActionA acts (fslI MsgAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -218,17 +222,28 @@ makeCourseUserTable cid acts restrict colChoices psValidator = do dbtCsvDecode = Nothing over _1 postprocess <$> dbTable psValidator DBTable{..} where - postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId) + postprocess :: FormResult (First act', DBFormResult UserId Bool UserTableData) -> FormResult (act', Set UserId) postprocess inp = do (First (Just act), usrMap) <- inp let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap return (act, usrSet) +courseUserDeregisterForm :: CourseId -> AForm Handler CourseUserActionData +courseUserDeregisterForm cid = wFormToAForm $ do + allocated <- liftHandler . runDB . E.selectExists . E.from $ \participant -> + E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid + E.&&. E.not_ (E.isNothing $ participant E.^. CourseParticipantAllocated) + if | allocated -> do + wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationAllocationShouldLogTip + fmap CourseUserDeregisterData <$> optionalActionW (areq (textField & cfStrip & guardField (not . null)) (fslI MsgCourseDeregistrationAllocationReason & setTooltip MsgCourseDeregistrationAllocationReasonTip) Nothing) (fslI MsgCourseDeregistrationAllocationShouldLog) (Just True) + | otherwise -> pure . pure $ CourseUserDeregisterData Nothing + getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCUsersR = postCUsersR postCUsersR tid ssh csh = do (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR + ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh let colChoices = mconcat [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey)) , colUserNameLink (CourseR tid ssh csh . CUserR) @@ -241,27 +256,33 @@ postCUsersR tid ssh csh = do , colUserComment tid ssh csh ] psValidator = def & defaultSortingByName - acts = catMaybes - [ Just CourseUserSendMail - , guardOn mayRegister CourseUserDeregister + acts = mconcat + [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData + , if + | mayRegister + -> singletonMap CourseUserDeregister $ courseUserDeregisterForm cid + | otherwise + -> mempty ] - ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh numParticipants <- count [CourseParticipantCourse ==. cid] table <- makeCourseUserTable cid acts (const E.true) colChoices psValidator return (ent, numParticipants, table) formResult participantRes $ \case - (CourseUserSendMail, selectedUsers) -> do + (CourseUserSendMailData, selectedUsers) -> do cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser] redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids]) - (CourseUserDeregister,selectedUsers) -> do - Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do - nrDel <- deleteWhereCount - [ CourseParticipantCourse ==. cid - , CourseParticipantUser ==. uid - ] - unless (nrDel == 0) $ - audit $ TransactionCourseParticipantDeleted cid uid - return $ Sum nrDel + (CourseUserDeregisterData{..}, selectedUsers) -> do + Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do + now <- liftIO getCurrentTime + Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid + lift $ delete reg + lift . audit $ TransactionCourseParticipantDeleted cid uid + case deregisterReason of + Just reason + | is _Just courseParticipantAllocated -> + lift . insert_ $ AllocationDeregister uid (Just cid) now (Just reason) + _other -> return () + return 1 addMessageI Success $ MsgCourseUsersDeregistered nrDel redirect $ CourseR tid ssh csh CUsersR let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|] diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 23203d2f2..a475e7ef6 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do { courseParticipantCourse = cid , courseParticipantUser = uid , courseParticipantRegistration = now - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index ff707cf04..483071cad 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do - insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False + insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 87f8e1cb5..084263183 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing } audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index c9d1e2677..740ed670d 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -61,7 +61,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do flip (renderAForm FormStandard) html $ MaterialForm <$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template) - <*> aopt (textField & cfStrip & cfCI & addDatalist typeOptions) + <*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions) (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder) (mfType <$> template) <*> aopt htmlField (fslpI MsgMaterialDescription "Html") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 57a49c428..a3f93daea 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -29,16 +29,17 @@ import Jobs data SettingsForm = SettingsForm - { stgDisplayName :: UserDisplayName - , stgDisplayEmail :: UserEmail - , stgMaxFavourties :: Int - , stgTheme :: Theme - , stgDateTime :: DateTimeFormat - , stgDate :: DateTimeFormat - , stgTime :: DateTimeFormat - , stgDownloadFiles :: Bool - , stgWarningDays :: NominalDiffTime - , stgSchools :: Set SchoolId + { stgDisplayName :: UserDisplayName + , stgDisplayEmail :: UserEmail + , stgMaxFavourites :: Int + , stgMaxFavouriteTerms :: Int + , stgTheme :: Theme + , stgDateTime :: DateTimeFormat + , stgDate :: DateTimeFormat + , stgTime :: DateTimeFormat + , stgDownloadFiles :: Bool + , stgWarningDays :: NominalDiffTime + , stgSchools :: Set SchoolId , stgNotificationSettings :: NotificationSettings } makeLenses_ ''SettingsForm @@ -49,6 +50,7 @@ data NotificationTriggerKind | NTKExamParticipant | NTKCorrector | NTKAllocationStaff + | NTKAllocationParticipant | NTKFunctionary SchoolFunction deriving (Eq, Ord, Generic, Typeable) deriveFinite ''NotificationTriggerKind @@ -60,6 +62,7 @@ instance RenderMessage UniWorX NotificationTriggerKind where NTKExamParticipant -> mr MsgNotificationTriggerKindExamParticipant NTKCorrector -> mr MsgNotificationTriggerKindCorrector NTKAllocationStaff -> mr MsgNotificationTriggerKindAllocationStaff + NTKAllocationParticipant -> mr MsgNotificationTriggerKindAllocationParticipant NTKFunctionary SchoolAdmin -> mr MsgNotificationTriggerKindAdmin NTKFunctionary SchoolLecturer -> mr MsgNotificationTriggerKindLecturer NTKFunctionary SchoolExamOffice -> mr MsgNotificationTriggerKindExamOffice @@ -75,8 +78,10 @@ makeSettingForm template html = do <*> areq (textField & cfStrip) (fslI MsgUserDisplayName & setTooltip MsgUserDisplayNameRulesBelow) (stgDisplayName <$> template) <*> areq (emailField & cfStrip & cfCI) (fslI MsgUserDisplayEmail & setTooltip MsgUserDisplayEmailTip) (stgDisplayEmail <$> template) <* aformSection MsgFormCosmetics - <*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here - (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) + <*> areq (natFieldI $ MsgNatField "Favoriten") + (fslpI MsgFavourites "Anzahl Favoriten" & setTooltip MsgFavouritesTip) (stgMaxFavourites <$> template) + <*> areq (natFieldI $ MsgNatField "Favoriten-Semester") + (fslpI MsgFavouriteSemesters "Anzahl Semester") (stgMaxFavouriteTerms <$> template) <*> areq (selectField . return $ mkOptionList themeList) (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) @@ -185,6 +190,7 @@ notificationForm template = wFormToAForm $ do NTAllocationRegister -> Just NTKAll NTAllocationOutdatedRatings -> Just NTKAllocationStaff NTAllocationUnratedApplications -> Just NTKAllocationStaff + NTAllocationResults -> Just NTKAllocationParticipant NTExamOfficeExamResults -> Just $ NTKFunctionary SchoolExamOffice NTExamOfficeExamResultsChanged -> Just $ NTKFunctionary SchoolExamOffice -- _other -> Nothing @@ -232,43 +238,38 @@ postProfileR = do E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId return $ school E.^. SchoolId let settingsTemplate = Just SettingsForm - { stgDisplayName = userDisplayName - , stgDisplayEmail = userDisplayEmail - , stgMaxFavourties = userMaxFavourites - , stgTheme = userTheme - , stgDateTime = userDateTimeFormat - , stgDate = userDateFormat - , stgTime = userTimeFormat - , stgDownloadFiles = userDownloadFiles - , stgSchools = userSchools + { stgDisplayName = userDisplayName + , stgDisplayEmail = userDisplayEmail + , stgMaxFavourites = userMaxFavourites + , stgMaxFavouriteTerms = userMaxFavouriteTerms + , stgTheme = userTheme + , stgDateTime = userDateTimeFormat + , stgDate = userDateFormat + , stgTime = userTimeFormat + , stgDownloadFiles = userDownloadFiles + , stgSchools = userSchools , stgNotificationSettings = userNotificationSettings - , stgWarningDays = userWarningDays + , stgWarningDays = userWarningDays } ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate formResult res $ \SettingsForm{..} -> do runDBJobs $ do update uid $ - [ UserDisplayName =. stgDisplayName - , UserMaxFavourites =. stgMaxFavourties - , UserTheme =. stgTheme - , UserDateTimeFormat =. stgDateTime - , UserDateFormat =. stgDate - , UserTimeFormat =. stgTime - , UserDownloadFiles =. stgDownloadFiles - , UserWarningDays =. stgWarningDays + [ UserDisplayName =. stgDisplayName + , UserMaxFavourites =. stgMaxFavourites + , UserMaxFavouriteTerms =. stgMaxFavouriteTerms + , UserTheme =. stgTheme + , UserDateTimeFormat =. stgDateTime + , UserDateFormat =. stgDate + , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles + , UserWarningDays =. stgWarningDays , UserNotificationSettings =. stgNotificationSettings ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] when (stgDisplayEmail /= userDisplayEmail) $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail - when (stgMaxFavourties < userMaxFavourites) $ do - -- prune Favourites to user-defined size - oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy stgMaxFavourties - ] - mapM_ delete oldFavs let symDiff = (stgSchools `Set.difference` userSchools) `Set.union` (userSchools `Set.difference` stgSchools) forM_ symDiff $ \ssh -> if diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 3c3921960..4c33dd1ee 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -14,6 +14,7 @@ import qualified Data.CaseInsensitive as CI import Data.Function ((&)) import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Database.Esqueleto as E @@ -51,7 +52,7 @@ postTUsersR tid ssh csh tutn = do E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh - table <- makeCourseUserTable cid universeF isInTut colChoices psValidator + table <- makeCourseUserTable cid (Map.fromList $ map (id &&& pure) universeF) isInTut colChoices psValidator return (tut, table) formResult participantRes $ \case diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 897fbd1ca..9e7ce758b 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -65,6 +65,7 @@ postAdminUserAddR = do newUser@User{..} = User { userIdent = aufIdent , userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , userTheme = userDefaultTheme , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs new file mode 100644 index 000000000..bcc17c0ef --- /dev/null +++ b/src/Handler/Utils/Allocation.hs @@ -0,0 +1,186 @@ +module Handler.Utils.Allocation + ( allocationDone + , ordinalPriorities + , sinkAllocationPriorities + , computeAllocation + , storeAllocationFingerprint + , doAllocation + , ppMatchingLog, storeMatchingLog + , storeAllocationResult + ) where + +import Import + +import qualified Data.Map.Strict as Map + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Control.Monad.State.Class as State (get, modify') + +import Data.List (genericLength, elemIndex) +import qualified Data.Vector as Vector +import Data.Vector.Lens (vector) +import qualified Data.Set as Set + +import System.Random (mkStdGen) + +import Utils.Allocation + +import qualified Data.Conduit.List as C +import Data.Conduit.Lift (evalStateC) + +import Data.Generics.Product.Param + +import qualified Crypto.Hash as Crypto +import qualified Data.Binary as Binary + +import qualified Data.ByteArray as BA (convert) + + +allocationDone :: AllocationId -> DB (Maybe UTCTime) +allocationDone allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val allocId) + return . E.max_ $ participant E.^. CourseParticipantRegistration + + +ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m () +ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ) + +sinkAllocationPriorities :: AllocationId + -> ConduitT (Map UserMatriculation AllocationPriority) Void DB () +sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio -> + E.update $ \allocationUser -> do + E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ] + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId + E.where_ . E.exists . E.from $ \user -> + E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser + E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr) + + +computeAllocation :: AllocationId + -> DB (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)) +computeAllocation allocId = do + users' <- selectList [ AllocationUserAllocation ==. allocId ] [] + let users'' = users' + & mapMaybe ( runMaybeT $ (,) <$> lift (allocationUserUser . entityVal) + <*> ( (,) <$> lift (allocationUserTotalCourses . entityVal) + <*> MaybeT (allocationUserPriority . entityVal) + ) + ) + & Map.fromList + & Map.filter ((> 0) . view _1) + cloneCounts = Map.map (view _1) users'' + allocationPrio = view _2 . (Map.!) users'' + + courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId + + let participants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser + return E.countRows + + return ( allocationCourse + , E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity) + , allocationCourse E.^. AllocationCourseMinCapacity E.-. participants + ) + let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses' + + applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] [] + let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal) + preferences = Map.fromList $ do + Entity _ CourseApplication{..} <- applications'' + return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints)) + + gradeScale <- getsYesod $ view _appAllocationGradeScale + gradeOrdinalPlaces <- getsYesod $ view _appAllocationGradeOrdinalPlaces + let centralNudge user cloneIndex grade = case allocationPrio user of + AllocationPriorityNumeric{..} + -> let allocationPriorities' = under vector (sortOn Down) allocationPriorities + minPrio | Vector.null allocationPriorities' = 0 + | otherwise = Vector.last allocationPriorities' + in AllocationPriorityComparisonNumeric . withNumericGrade . fromInteger . fromMaybe minPrio $ allocationPriorities Vector.!? fromIntegral cloneIndex + AllocationPriorityOrdinal{..} + | gradeOrdinalPlaces > 0 + -> let allocationOrdinal' = gradeScale / fromIntegral gradeOrdinalPlaces * fromIntegral allocationOrdinal + in AllocationPriorityComparisonOrdinal (Down cloneIndex) $ withNumericGrade allocationOrdinal' + AllocationPriorityOrdinal{..} + -> AllocationPriorityComparisonOrdinal (Down cloneIndex) $ fromIntegral allocationOrdinal + where + withNumericGrade :: Rational -> Rational + withNumericGrade + | Just grade' <- grade + = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades) + passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF + numericGrade = -gradeScale + numberGrade' * 2 * gradeScale + in (+) numericGrade + | otherwise + = id + + let + fingerprint :: AllocationFingerprint + fingerprint = Crypto.hash . toStrict $ Binary.encode (users'', capacities, preferences, gradeScale, gradeOrdinalPlaces) + + g = mkStdGen $ hash (BA.convert fingerprint :: ByteString) + + let + doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge + where + capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities + preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences + + allocationLoop cs + | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin + | otherwise = (allocs, mLog) + where + (allocs, mLog) = doAllocationWithout cs + belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) -> + guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse + + return . (\(ms, mLog) -> (fingerprint, ms, mLog)) $!! allocationLoop Set.empty + + +storeAllocationFingerprint :: AllocationId + -> AllocationFingerprint + -> DB () +storeAllocationFingerprint allocId fp = update allocId [ AllocationFingerprint =. Just fp ] + +doAllocation :: AllocationId + -> Set (UserId, CourseId) + -> DB () +doAllocation allocId regs = do + now <- liftIO getCurrentTime + forM_ regs $ \(uid, cid) -> do + mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] + void . insertUnique $ CourseParticipant cid uid now mField (Just allocId) + +ppMatchingLog :: ( MonoFoldable mono + , Element mono ~ MatchingLog UserId CourseId Natural + ) + => mono -> Text +ppMatchingLog = unlines . map (tshow . pretty) . otoList + where + pretty = over (param @1) fromSqlKey + . over (param @2) fromSqlKey + +storeMatchingLog :: ( MonoFoldable mono + , Element mono ~ MatchingLog UserId CourseId Natural + ) + => AllocationId -> mono -> DB () +storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do + now <- liftIO getCurrentTime + fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now + update allocationId [ AllocationMatchingLog =. Just fId ] + + +storeAllocationResult :: AllocationId + -> (AllocationFingerprint, Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)) + -> DB () +storeAllocationResult allocId (allocFp, allocMatchings, allocLog) = do + storeAllocationFingerprint allocId allocFp + doAllocation allocId allocMatchings + storeMatchingLog allocId allocLog diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index bc0617d29..b13e2c0e3 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( decodeCsv + ( decodeCsv, decodeCsvPositional , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB @@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A +import Control.Monad.Except (ExceptT) + decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () -decodeCsv = transPipe throwExceptT $ do +decodeCsv = decodeCsv' fromNamedCsv + +decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m () +decodeCsvPositional hdr = decodeCsv' (`fromCsv` hdr) + +decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () +decodeCsv' fromCsv' = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer @@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do & guessDelimiter testBuffer $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] - fromNamedCsv decodeOptions + fromCsv' decodeOptions where testBufferSize = 4096 accumTestBuffer acc diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 6c5e6a0f2..291d8f34c 100644 --- a/src/Handler/Utils/Delete.hs +++ b/src/Handler/Utils/Delete.hs @@ -53,14 +53,17 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet where aform = (,) <$> areq confirmField (fslI MsgDeleteConfirmation) Nothing - <*> disambiguateButtons (combinedButtonFieldF "") + <*> pure BtnDelete confirmField | multiple = convertField unTextarea Textarea textareaField | otherwise = textField multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1 +confirmFormReduced :: Monad m => AForm m Bool +confirmFormReduced = pure True + confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool -confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString +confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString where addDeleteTargets :: Form a -> Form a addDeleteTargets form csrf = do @@ -99,10 +102,10 @@ getDeleteR DeleteRoute{..} = do (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute - let deleteForm = wrapForm deleteFormWdgt def + let deleteForm = wrapForm' BtnDelete deleteFormWdgt def { formAction = Just $ SomeRoute targetRoute , formEncoding = deleteFormEnctype - , formSubmit = FormNoSubmit + , formSubmit = FormSubmit } sendResponse =<< diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index be29cc456..fcd084a43 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -747,10 +747,11 @@ multiFileField permittedFiles' = Field{..} | otherwise = True return FileUploadInfo{..} autoUnzipInfo = [whamlet| _{MsgAutoUnzipInfo} |] - fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do + fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals) E.orderBy [E.asc $ file E.^. FileTitle] return (file E.^. FileId, file E.^. FileTitle) + let fileInfos = sortOn fuiTitle fileInfos' $(widgetFile "widgets/multiFileField") unpackZips :: Text unpackZips = "unpack-zip" diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a268d550a..a5845696b 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -961,7 +961,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (Map.findWithDefault (error $ "Invalid filter key: " <> show key) key dbtFilter) args t) >> expr) (return ()) psFilter return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res) - let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v) + let mapMaybeM' f = mapMaybeM $ \(k, v) -> (,) <$> pure k <*> f v firstRow :: Int64 firstRow | PagesizeLimit l <- psLimit @@ -974,7 +974,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db | otherwise = id - (currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows' + (currentKeys, rows) <- fmap unzip . mapMaybeM' dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) . zip [firstRow..] $ reproduceSorting rows' formResult csvMode $ \case diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 1fde2b42c..a852dcdc7 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -15,6 +15,7 @@ import Data.Time.Zones import Data.Time.Clock.POSIX import Handler.Utils.DateTime +import Handler.Utils.Allocation (allocationDone) import Control.Monad.Trans.Writer (WriterT, execWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) @@ -336,5 +337,15 @@ determineCrontab = execWriterT $ do } _other -> return () + doneSince <- lift $ allocationDone nAllocation + whenIsJust doneSince $ \doneSince' -> + tell $ HashMap.singleton + (JobCtlQueue $ JobQueueNotification NotificationAllocationResults{..}) + Cron + { cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay doneSince' + , cronRepeat = CronRepeatNever + , cronRateLimit = appNotificationRateLimit + , cronNotAfter = Left appNotificationExpiration + } runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ allocationJobs diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index 93f5d0c33..08a1b6ff0 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/src/Jobs/Handler/QueueNotification.hs @@ -198,6 +198,18 @@ determineNotificationCandidates NotificationExamOfficeExamResultsChanged{..} = E.where_ $ examResult E.^. ExamResultId `E.in_` E.valList (Set.toList nExamResults) E.where_ $ examOfficeExamResultAuth (user E.^. UserId) examResult return user +determineNotificationCandidates NotificationAllocationResults{..} = + E.select . E.from $ \user -> do + let isStudent = E.exists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation) + E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId + isLecturer = E.exists . E.from $ \(lecturer `E.InnerJoin` allocationCourse) -> + E.on $ lecturer E.^. LecturerCourse E.==. allocationCourse E.^. AllocationCourseCourse + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + E.&&. lecturer E.^. LecturerUser E.==. user E.^. UserId + E.where_ $ isStudent E.||. isLecturer + + return user classifyNotification :: Notification -> DB NotificationTrigger @@ -224,3 +236,4 @@ classifyNotification NotificationAllocationOutdatedRatings{} = return NTAll classifyNotification NotificationAllocationUnratedApplications{} = return NTAllocationUnratedApplications classifyNotification NotificationExamOfficeExamResults{} = return NTExamOfficeExamResults classifyNotification NotificationExamOfficeExamResultsChanged{} = return NTExamOfficeExamResultsChanged +classifyNotification NotificationAllocationResults{} = return NTAllocationResults diff --git a/src/Jobs/Handler/SendNotification/Allocation.hs b/src/Jobs/Handler/SendNotification/Allocation.hs index b4cc9330f..914fb05db 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 , dispatchNotificationAllocationOutdatedRatings + , dispatchNotificationAllocationResults ) where import Import @@ -157,3 +158,43 @@ dispatchNotificationAllocationOutdatedRatings nAllocation jRecipient = do addAlternatives $ providePreferredAlternative $(ihamletFile "templates/mail/allocationOutdatedRatings.hamlet") +dispatchNotificationAllocationResults :: AllocationId -> UserId -> Handler () +dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipient $ do + (Allocation{..}, lecturerResults, participantResults) <- liftHandler . runDB $ do + allocation <- getJust nAllocation + + lecturerResults' <- E.select . E.from $ \(lecturer `E.InnerJoin` course) -> do + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.where_ $ lecturer E.^. LecturerUser E.==. E.val jRecipient + E.&&. E.exists (E.from $ \allocationCourse -> + E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val nAllocation + ) + let participantCount = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantCourse E.==. lecturer E.^. LecturerCourse + E.&&. participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) + return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64)) + return (course, participantCount) + let lecturerResults = flip map lecturerResults' $ \(Entity _ Course{..}, E.Value partCount) -> SomeMessage $ MsgAllocationResultLecturer courseShorthand partCount + + doParticipantResults <- E.selectExists . E.from $ \application -> + E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just (E.val nAllocation) + E.&&. application E.^. CourseApplicationUser E.==. E.val jRecipient + participantResults' <- E.select . E.from $ \(participant `E.InnerJoin` course) -> do + E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.where_ $ participant E.^. CourseParticipantAllocated E.==. E.just (E.val nAllocation) + E.&&. participant E.^. CourseParticipantUser E.==. E.val jRecipient + return course + let participantResults = case participantResults' of + [] | doParticipantResults -> Just [] + | otherwise -> Nothing + cs -> Just $ map (courseShorthand . entityVal) cs + + return (allocation, lecturerResults, participantResults) + + replaceMailHeader "Auto-Submitted" $ Just "auto-generated" + setSubjectI $ MsgMailSubjectAllocationResults allocationName + editNotifications <- mkEditNotifications jRecipient + + addAlternatives $ + providePreferredAlternative $(ihamletFile "templates/mail/allocationResults.hamlet") diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 4edfa2f10..85a410b89 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -87,6 +87,7 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationAllocationOutdatedRatings { nAllocation :: AllocationId } | NotificationExamOfficeExamResults { nExam :: ExamId } | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId } + | NotificationAllocationResults { nAllocation :: AllocationId } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Hashable Job diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 2c033b534..488d4c546 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -550,6 +550,24 @@ customMigrations = Map.fromListWith (>>) UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; |] ) + , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|] + , whenM (tableExists "course_favourite") $ + [executeQQ| + ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit"; + ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb; + |] + ) + , ( AppliedMigrationKey [migrationVersion|24.0.0|] [version|25.0.0|] + , whenM (tableExists "course_participant") $ do + queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|] + case queryRes of + [Single False] -> + [executeQQ| + ALTER TABLE "course_participant" DROP COLUMN "allocated"; + ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint; + |] + _other -> error "Cannot reconstruct course_participant.allocated" + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f6cc46755..2dff836fe 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -13,3 +13,4 @@ import Model.Types.Sheet as Types import Model.Types.Submission as Types import Model.Types.Misc as Types import Model.Types.School as Types +import Model.Types.Allocation as Types diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs new file mode 100644 index 000000000..7eca27b58 --- /dev/null +++ b/src/Model/Types/Allocation.hs @@ -0,0 +1,52 @@ +module Model.Types.Allocation + ( AllocationPriority(..) + , AllocationPriorityComparison(..) + , AllocationFingerprint + , module Utils.Allocation + ) where + +import Import.NoModel +import Utils.Allocation (MatchingLog(..)) +import Model.Types.Common + +import qualified Data.Csv as Csv +import qualified Data.Vector as Vector + +import qualified Data.Map.Strict as Map + +import Crypto.Hash (Digest, SHAKE128) + +{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-} + + +data AllocationPriority + = AllocationPriorityNumeric { allocationPriorities :: Vector Integer } + | AllocationPriorityOrdinal { allocationOrdinal :: Natural } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 2 + , allNullaryToStringTag = False + , sumEncoding = TaggedObject "mode" "value" + , unwrapUnaryRecords = False + , tagSingleConstructors = True + } ''AllocationPriority +derivePersistFieldJSON ''AllocationPriority + +instance Binary AllocationPriority + +instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where + parseRecord v = parseNumeric + where + parseNumeric + | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v)) + | otherwise = mzero + + +data AllocationPriorityComparison + = AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational } + | AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +type AllocationFingerprint = Digest (SHAKE128 128) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index d7a1ae6e3..afd09396e 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -218,6 +218,8 @@ instance PersistField ExamGrade where instance PersistFieldSql ExamGrade where sqlType _ = SqlNumeric 2 1 +instance Binary ExamGrade + newtype ExamGradeDefCenter = ExamGradeDefCenter { examGradeDefCenter :: Maybe ExamGrade } deriving (Eq, Read, Show, Generic, Typeable) diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 3e04dd5b8..2ee82574f 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -40,6 +40,7 @@ data NotificationTrigger | NTAllocationRegister | NTAllocationOutdatedRatings | NTAllocationUnratedApplications + | NTAllocationResults | NTExamOfficeExamResults | NTExamOfficeExamResultsChanged deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index 3444afb07..9a11e1379 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -131,3 +131,17 @@ instance YesodMail site => ToMailPart site (CsvRendered, CsvOptions) where _partContent .= Csv.encodeByNameWith (encOpts ^. _CsvEncodeOptions) csvRenderedHeader csvRenderedData instance YesodMail site => ToMailPart site CsvRendered where toMailPart = toMailPart . (, def :: CsvOptions) + + +data FavouriteReason + = FavouriteVisited + | FavouriteParticipant + | FavouriteManual + | FavouriteCurrent + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe FavouriteReason +instance Finite FavouriteReason +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''FavouriteReason +derivePersistFieldJSON ''FavouriteReason diff --git a/src/Settings.hs b/src/Settings.hs index 48d70d396..9fc92048b 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore import Data.Time (NominalDiffTime, nominalDay) -import Data.Scientific (toBoundedInteger) +import Data.Scientific (Scientific, toBoundedInteger) import Data.Word (Word16) import qualified Data.Text as Text @@ -130,6 +130,9 @@ data AppSettings = AppSettings , appTransactionLogIPRetentionTime :: NominalDiffTime + , appAllocationGradeScale :: Rational + , appAllocationGradeOrdinalPlaces :: Natural + , appReloadTemplates :: Bool -- ^ Use the reload version of templates , appMutableStatic :: Bool @@ -168,7 +171,7 @@ instance NFData LogDestination data UserDefaultConf = UserDefaultConf { userDefaultTheme :: Theme - , userDefaultMaxFavourites :: Int + , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat , userDefaultDownloadFiles :: Bool , userDefaultWarningDays :: NominalDiffTime @@ -426,6 +429,9 @@ instance FromJSON AppSettings where appTransactionLogIPRetentionTime <- o .: "ip-retention-time" + appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific) + appAllocationGradeOrdinalPlaces <- o .: "allocation-grade-ordinal-places" + appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" diff --git a/src/Utils.hs b/src/Utils.hs index 82c19d0b2..65ea3be49 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -51,7 +51,9 @@ import Control.Arrow as Utils ((>>>)) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Except (MonadError(..)) import Control.Monad.Trans.Maybe as Utils (MaybeT(..)) +import Control.Monad.Trans.Writer.Lazy (execWriterT, tell) import Control.Monad.Catch +import Control.Monad.Morph (hoist) import Language.Haskell.TH import Language.Haskell.TH.Instances () @@ -529,6 +531,20 @@ maybeThrow exc = maybe (throwM exc) return maybeThrowM :: (MonadThrow m, Exception e) => m e -> Maybe a -> m a maybeThrowM excM = maybe (throwM =<< excM) return +mapMaybeM :: ( Monad m + , MonoFoldable (f a) + , MonoPointed (f b) + , Monoid (f b) + ) => (Element (f a) -> MaybeT m (Element (f b))) -> f a -> m (f b) +mapMaybeM f = execWriterT . mapM_ (void . runMaybeT . (lift . tell . opoint <=< hoist lift . f)) + +forMaybeM :: ( Monad m + , MonoFoldable (f a) + , MonoPointed (f b) + , Monoid (f b) + ) => f a -> (Element (f a) -> MaybeT m (Element (f b))) -> m (f b) +forMaybeM = flip mapMaybeM + ------------ -- Either -- ------------ diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs new file mode 100644 index 000000000..d5e80c6b4 --- /dev/null +++ b/src/Utils/Allocation.hs @@ -0,0 +1,281 @@ +module Utils.Allocation + ( computeMatching + , MatchingLog(..) + , computeMatchingLog + ) where + +import Import.NoModel hiding (StateT, st, get) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + +import Data.Array.ST (STArray) +import qualified Data.Array.MArray as MArr + +import System.Random (RandomGen) +import Control.Monad.Random.Class (getRandom) +import Control.Monad.Trans.Random.Strict (evalRandT, RandT) +import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT) +import Control.Monad.Writer (tell) + +import Control.Monad.ST + +import Data.List ((!!), elemIndex) + + +type CourseIndex = Int +type StudentIndex = Int +type CloneIndex = Int + +data MatchingLog student course cloneIndex + = MatchingConsider + { mlStudent :: student, mlClone :: cloneIndex } + | MatchingApply + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingNoApplyCloneInstability + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingLostSpot + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex) + +computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. + ( RandomGen randomGen + , Ord student, Ord course + , NFData student + , Ord studentRatingCourse + , Ord courseRatingStudent + , Ord courseRatingStudent' + , Integral cloneCount, Integral capacity, Num cloneIndex + ) + => randomGen -- ^ Source of randomness + -> Map student cloneCount -- ^ requested number of placements per student + -> Map course (Maybe capacity) -- ^ capacity of courses + -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ + -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) + -> Set (student, course) -- ^ Stable matching +computeMatching g cloneCounts capacities preferences centralNudge + = view _1 . runWriter $ computeMatchingLog g cloneCounts capacities preferences centralNudge + +computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. + ( RandomGen randomGen + , Ord student, Ord course + , NFData student + , Ord studentRatingCourse + , Ord courseRatingStudent + , Ord courseRatingStudent' + , Integral cloneCount, Integral capacity, Num cloneIndex + ) + => randomGen -- ^ Source of randomness + -> Map student cloneCount -- ^ requested number of placements per student + -> Map course (Maybe capacity) -- ^ capacity of courses + -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ + -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) + -> Writer (Seq (MatchingLog student course cloneIndex)) (Set (student, course)) -- ^ Stable matching +computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ runST computeMatching' + where + computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex)) + computeMatching' = runWriterT . flip evalRandT g $ do + stb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) ((student, CloneIndex) -> UUID) + cstb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) courses) :: RandT randomGen (WriterT _ (ST s)) (course -> UUID) + + courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s CourseIndex (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)))) + + stPrefs <- lift . lift $ MArr.newArray studentBounds [] :: RandT randomGen (WriterT _ (ST s)) (STArray s (StudentIndex, CloneIndex) [course]) + forM_ clonedStudents $ \(st, cn) -> + lift . lift . MArr.writeArray stPrefs (st ^. contStudents, cn) $ studentPrefs cstb (st, cn) + + let + propose :: StateT (Set (student, CloneIndex)) (WriterT _ (ST s)) () + propose = (=<< get) . mapM_ $ \(st, cn) -> do + lift . tell . pure . MatchingConsider st $ fromIntegral cn + let markDone = modify' $ Set.delete (st, cn) + + options <- lift . lift $ MArr.readArray stPrefs (st ^. contStudents, cn) + case options of + [] -> markDone + c : cs -> do + lift . lift $ MArr.writeArray stPrefs (st ^. contStudents, cn) cs + cState <- lift . lift $ MArr.readArray courses' (c ^. contCourses) + case cState of + Left pSet + | none (\(st', _) -> st == st') pSet -> do + lift . tell . pure $ MatchingApply st (fromIntegral cn) c + lift . lift . MArr.writeArray courses' (c ^. contCourses) $!! Left (Set.insert (st, cn) pSet) + markDone + Right spots + | none (\(st', _) -> st == st') spots -> do + courseMatchings <- lift . lift $ MArr.getAssocs courses' + let + matchingCourse s cn' = listToMaybe $ do + (review contCourses -> course, students) <- courseMatchings + student <- case students of + Left pSet -> toList pSet + Right spots' -> toList spots' + guard $ (s, cn') == student + return course + + let capacity = maybe (error "course without capacity treated as one") fromIntegral . fromMaybe (error "course not found in capacities") $ capacities Map.!? c + (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots + isWorseSpot existing = case (comparing $ fromMaybe (error "(st, c) not in preferences") . courseRating c &&& stb) existing (st, cn) of + EQ -> error "Two student-clones compared equal in the face of stb" + GT -> False + LT -> True + (newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots + + isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool + isUnstableWith cn' (stO, cnO) = fromMaybe False $ do + c' <- matchingCourse st cn' + rMe <- courseRating c' (st, cn') + rOther <- courseRating c' (stO, cnO) + return $ LT == compare (rMe, stb (st, cn')) (rOther, stb (stO, cnO)) + + if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots + -> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c + | Seq.length betterSpots >= capacity + -> return () + | otherwise + -> do + lift . tell . pure $ MatchingApply st (fromIntegral cn) c + lift . lift . MArr.writeArray courses' (c ^. contCourses) $ Right newSpots + forM_ lostSpots $ \(st', cn') -> do + lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c + modify' $ Set.insert (st', cn') + markDone + _other -> return () + + proposeLoop = do + propose + done <- gets Set.null + unless done + proposeLoop + + lift $ evalStateT proposeLoop clonedStudents + + + -- let + -- pairwiseExchange :: ST s () + -- pairwiseExchange = do + -- let possiblePairs = do + -- (s:ss) <- tails . sortOn stb $ toList clonedStudents + -- s' <- ss + -- return (s, s') + -- matchingCourse (s, c) = do + -- courseMatchings <- MArr.getAssocs courses' + -- return . listToMaybe $ do + -- (course, students) <- courseMatchings + -- student <- case students of + -- Left pSet -> toList pSet + -- Right spots -> toList spots + -- guard $ (s, c) == student + -- return course + -- forM_ possiblePairs $ \((a, cna), (b, cnb)) -> void . runMaybeT $ do + -- ca <- MaybeT $ matchingCourse (a, cna) + -- cb <- MaybeT $ matchingCourse (b, cnb) + + -- let rank (s, cn) c = Seq.elemIndexL c $ studentPrefs cstb (s, cn) + -- caRa <- hoistMaybe $ rank (a, cna) ca + -- caRb <- hoistMaybe $ rank (b, cnb) ca + -- cbRa <- hoistMaybe $ rank (a, cna) cb + -- cbRb <- hoistMaybe $ rank (b, cnb) cb + + -- let currentRanks cop = caRa `cop` cbRb + -- newRanks cop = cbRa `cop` caRb + + -- swapImproves = or + -- [ currentRanks (+) > newRanks (+) + -- , currentRanks (+) == newRanks (+) + -- && currentRanks min > newRanks min + -- ] + -- lift . when swapImproves $ do + -- traceM $ show (a, cna) <> " `swap` " <> show (b, cnb) + -- let + -- addCourseUser :: course -> (student, CloneIndex) -> ST s () + -- addCourseUser c (st, cn) = do + -- cState <- MArr.readArray courses' c + -- case cState of + -- Left pSet -> + -- MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet) + -- Right spots -> + -- let (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots + -- isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of + -- EQ -> error "Two student-clones compared equal in the face of stb" + -- GT -> False + -- LT -> True + -- newSpots = force $ betterSpots <> Seq.singleton (st, cn) <> worseSpots + -- in MArr.writeArray courses' c $ Right newSpots + -- remCourseUser :: course -> (student, CloneIndex) -> ST s () + -- remCourseUser c (st, cn) = do + -- cState <- MArr.readArray courses' c + -- case cState of + -- Left pSet -> + -- MArr.writeArray courses' c $!! Left (Set.delete (st, cn) pSet) + -- Right spots -> + -- MArr.writeArray courses' c $!! Right (Seq.filter (/= (st, cn)) spots) + + -- remCourseUser ca (a, cna) + -- remCourseUser cb (b, cnb) + -- addCourseUser cb (a, cna) + -- addCourseUser ca (b, cnb) + + -- lift pairwiseExchange + + + courseMatchings <- lift . lift $ MArr.getAssocs courses' + return . Set.fromList $ do + (review contCourses -> course, students) <- courseMatchings + student <- case students of + Left pSet -> view _1 <$> toList pSet + Right spots -> view _1 <$> toList spots + return (student, course) + + courseRating :: course -> (student, CloneIndex) -> Maybe courseRatingStudent' + courseRating c (st, cn) = do + (_, courseRating') <- preferences Map.!? (st, c) + return $ centralNudge st (fromIntegral cn) courseRating' + + clonedStudents :: Set (student, CloneIndex) + clonedStudents = Set.fromDistinctAscList $ do + (student, clones) <- Map.toAscList cloneCounts + clone <- [0,1..pred $ fromIntegral clones] + return (student, clone) + + contStudents :: Iso' student StudentIndex + contStudents = iso toInt fromInt + where + students' = Map.keys cloneCounts + + toInt = fromMaybe (error "trying to resolve unknown student") . flip elemIndex students' + fromInt = (!!) students' + + studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex)) + studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts)) + + courses :: Set course + courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities + courseBounds :: (CourseIndex, CourseIndex) + courseBounds = (0, pred $ Set.size courses) + + contCourses :: Iso' course CourseIndex + contCourses = iso toInt fromInt + where + courses' = Set.toAscList courses + + toInt = fromMaybe (error "trying to resolve unknown course") . flip elemIndex courses' + fromInt = (!!) courses' + + initCourse :: course -> Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)) + initCourse c + | is _Just . join $ Map.lookup c capacities + = Right Seq.empty + | otherwise + = Left Set.empty + + studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> [course] + studentPrefs cstb (st, _) = map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses + where + cPref :: course -> Maybe (studentRatingCourse, a) + cPref c = do + (cPref', _) <- Map.lookup (st, c) preferences + return (cPref', cstb c) diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 80a4443db..392ade039 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -196,6 +196,7 @@ data FormIdentifier | FIDcourseRegister | FIDsheet | FIDmaterial + | FIDCourseNews | FIDsubmission | FIDsettings | FIDcorrectors diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index a97ae8355..234ab1075 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -19,10 +19,14 @@ import Utils.Lens.TH as Utils.Lens import Data.Set.Lens as Utils.Lens import Data.Map.Lens as Utils.Lens +import Data.Generics.Product.Types as Utils.Lens + import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) +import qualified Data.CaseInsensitive as CI + _PathPiece :: PathPiece v => Prism' Text v _PathPiece = prism' toPathPiece fromPathPiece @@ -48,6 +52,9 @@ _SchoolId = iso unSchoolKey SchoolKey _Maybe :: Iso' (Maybe ()) Bool _Maybe = iso (is _Just) (bool Nothing (Just ())) +_CI :: FoldCase s => Iso' (CI s) s +_CI = iso CI.original CI.mk + ----------------------------------- -- Lens Definitions for our Types @@ -197,6 +204,10 @@ makeLenses_ ''SchoolLdap makeLenses_ ''UserFunction makeLenses_ ''CourseUserExamOfficeOptOut + +makeLenses_ ''CourseNewsFile + +makeLenses_ ''AllocationCourse -- makeClassy_ ''Load diff --git a/stack.yaml b/stack.yaml index 46618df8e..f83be73a7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -58,5 +58,7 @@ extra-deps: - process-1.6.5.1 + - generic-lens-1.2.0.0 + resolver: lts-13.21 allow-newer: true diff --git a/stack.yaml.lock b/stack.yaml.lock index 92aae0cdf..3758cb266 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -235,6 +235,13 @@ packages: sha256: 19d944da6aa37944332e0726372288319852e5f72aa57dbc3516dc15e760a502 original: hackage: process-1.6.5.1 +- completed: + hackage: generic-lens-1.2.0.0@sha256:b19e7970c93743a46bc3702331512a96d163de4356472f2d51a2945887aefe8c,6524 + pantry-tree: + size: 4315 + sha256: 9ed161eadfda5b1eb36cfcf077146f7b66db1da69f1041fc720aea287ec021b0 + original: + hackage: generic-lens-1.2.0.0 snapshots: - completed: size: 498180 diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index 3f0e97fe1..f6a2312a3 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -1,13 +1,24 @@ $newline never
- $#

- $# _{MsgAllocationData}
+
+ _{MsgAllocationSemester} +
+ _{unTermKey allocationTerm} +
+ _{MsgAllocationSchool} +
+ #{schoolName} $maybe desc <- allocationDescription
_{MsgAllocationDescription}
#{desc} + $maybe desc <- guardOn isAnyLecturer =<< allocationStaffDescription +
+ _{MsgAllocationStaffDescription} +
+ #{desc} $maybe fromT <- allocationStaffRegisterFrom
$maybe _ <- allocationStaffRegisterTo @@ -32,14 +43,36 @@ $newline never _{MsgAllocationStaffAllocationFrom}
^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo} - - $# TODO show datetime of automatic allocation - $# - $#
- $# _{MsgAllocationProcess} - $#
- $# ^{formatTimeRangeW SelFormatDateTime fromT allocationProcess} - $# + $maybe fromT <- allocationRegisterByStaffFrom +
+ $maybe _ <- allocationRegisterByStaffTo + _{MsgAllocationRegisterByStaff} + + + + _{MsgAllocationRegisterByStaffTip} + $nothing + _{MsgAllocationRegisterByStaffFrom} + + + + _{MsgAllocationRegisterByStaffFromTip} +
+ ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo} + $maybe fromT <- allocationRegisterByCourse +
+ _{MsgAllocationRegisterByCourseFrom} + + + + _{MsgAllocationRegisterByCourseFromTip} +
+ ^{formatTimeW SelFormatDateTime fromT} + $maybe toT <- allocationOverrideDeregister +
+ _{MsgAllocationOverrideDeregister} +
+

^{formatTimeW SelFormatDateTime toT}

diff --git a/templates/allocation/show.lucius b/templates/allocation/show.lucius index 54e085ed3..5302b59a4 100644 --- a/templates/allocation/show.lucius +++ b/templates/allocation/show.lucius @@ -17,10 +17,11 @@ display: grid; grid-template-columns: minmax(105px, 1fr) 9fr; grid-template-areas: - 'name name ' - 'prio-label prio ' - 'instr-label instr ' - 'form-label form '; + 'name name ' + '. registered ' + 'prio-label prio ' + 'instr-label instr ' + 'form-label form '; grid-gap: 5px 7px; margin: 12px 0; @@ -41,6 +42,10 @@ background-color: rgba(0, 0, 0, 0.015); } + .allocation-course__registered { + grid-area: registered; + } + .allocation-course__priority { grid-area: prio; } @@ -84,6 +89,7 @@ grid-template-columns: 1fr; grid-template-areas: 'name ' + 'registered ' 'prio-label ' 'prio ' 'instr-label' diff --git a/templates/allocation/show/course.hamlet b/templates/allocation/show/course.hamlet index 53992eed4..4972ae661 100644 --- a/templates/allocation/show/course.hamlet +++ b/templates/allocation/show/course.hamlet @@ -1,3 +1,7 @@ +$if isRegistered +
+ #{iconOK} + \ _{MsgRegistered} $if is _Just muid
_{MsgAllocationPriority} diff --git a/templates/course-news.hamlet b/templates/course-news.hamlet new file mode 100644 index 000000000..5ba795962 --- /dev/null +++ b/templates/course-news.hamlet @@ -0,0 +1,12 @@ +$newline never +$maybe summary <- courseNewsSummary +
+
+
+ _{MsgCourseNewsSummary} +
+ #{summary} +
+ #{courseNewsContent} +$nothing + #{courseNewsContent} diff --git a/templates/course.hamlet b/templates/course.hamlet index 1372fd58d..d174fe99a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -1,16 +1,78 @@ $newline never
-
Fakultät/Institut -
-
- #{schoolName} - + $if not (null news) || mayCreateNews +
+ _{MsgCourseNews} + $if not visibleNews + \ #{iconInvisible} +
+ $if not (null news) +