Merge branch 'master' into info-lecturer

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)
 
 

config/settings.yml

@@ -122,13 +122,23 @@ widget-memcached:
   expiration: "_env:MEMCACHEDEXPIRATION:3600"
 
 user-defaults:
-  max-favourites:   12
+  max-favourites:      12
-  theme:            Default
+  max-favourite-terms: 2
-  date-time-format: "%a %d %b %Y %R"
+  theme:               Default
-  date-format:      "%d.%m.%Y"
+  date-time-format:    "%a %d %b %Y %R"
-  time-format:      "%R"
+  date-format:         "%d.%m.%Y"
-  download-files:   false
+  time-format:         "%R"
-  warning-days:     1209600
+  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:"

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 {

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

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

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

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

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

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
+  file     FileId
+  UniqueMaterialFile material file

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

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

package-lock.json

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

package.json

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

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)

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

src/CryptoID.hs

@@ -48,6 +48,7 @@ decCryptoIDs [ ''SubmissionId
              , ''AllocationId
              , ''CourseApplicationId
              , ''CourseId
+             , ''CourseNewsId
              ]
 
 -- CryptoIDNamespace (CI FilePath) SubmissionId ~ "Submission"

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 allocationRegisterByStaffTo <= NTop (Just now)
-          || NTop allocationStaffRegisterFrom >= 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
+tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
-  CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
+  CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsParticipant) $ do
-    cTime <- liftIO getCurrentTime
+    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
-    let
+    CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
-      authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult DB ()
+    if | courseNewsParticipantsOnly -> do
-      authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
+           uid <- hoistMaybe mAuthId
-    participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
+           exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid
-    -- participant is currently registered
+       | otherwise
-    $cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
+           -> return Authorized
-      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)
 
+  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
+                User{userMaxFavourites} <- MaybeT $ get uid
-                let courseFavourite = CourseFavourite uid now cid
 
-                $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
                 -- update Favourites
                 void . lift $ upsertBy
                   (UniqueCourseFavourite uid cid)
-                  courseFavourite
+                  (CourseFavourite uid cid FavouriteVisited now)
-                  [CourseFavouriteTime =. now]
+                  [CourseFavouriteLastVisit =. now]
                 -- prune Favourites to user-defined size
-                oldFavs <- lift $ selectKeysList
+                oldFavs <- lift $ selectList [CourseFavouriteUser ==. uid] []
-                  [ CourseFavouriteUser ==. uid]
+                let deleteFavs = oldFavs
-                  [ Desc CourseFavouriteTime
+                      & sortOn ((courseFavouriteReason &&& Down . courseFavouriteLastVisit) . entityVal)
-                  , OffsetBy $ userMaxFavourites user
+                      & drop userMaxFavourites
-                  ]
+                      & filter ((<= FavouriteVisited) . courseFavouriteReason . entityVal)
-                lift . forM_ oldFavs $ \fav -> do
+                      & map entityKey
-                  $logDebugS "updateFavourites" "Deleting old favourite."
+                unless (null deleteFavs) $
-                  delete fav
+                  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?!
+  -- Lookup Favourites & Theme if possible
-  (favourites', currentTheme) <- do
+  (favourites', maxFavouriteTerms, currentTheme) <- do
       muid <- maybeAuthPair
-      case muid of
+
-          Nothing         -> return ([],userDefaultTheme)
+      favCourses <- runDB . E.select . E.from $ \(course `E.LeftOuterJoin` courseFavourite) -> do
-          (Just (uid,user)) -> do
+        E.on $ E.just (course E.^. CourseId) E.==. courseFavourite E.?. CourseFavouriteCourse
-              favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
+         E.&&. courseFavourite E.?. CourseFavouriteUser E.==. E.val (view _1 <$> muid)
-                  E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
+
-                  E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
+        let isFavourite = E.not_ . E.isNothing $ courseFavourite E.?. CourseFavouriteId
-                  E.orderBy [ E.asc $ course E.^. CourseShorthand ]
+            isCurrent
-                  return course
+              | Just (CourseR tid ssh csh _) <- mcurrentRoute
-              return (favs, userTheme user)
+              =       course E.^. CourseTerm E.==. E.val tid
-  favourites <- forM favourites' $ \(Entity _ c@Course{..})
+                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
+      favouriteTerms = take maxFavouriteTerms . Set.toDescList $ foldMap (\(Course{..}, _, _, _) -> Set.singleton $ unTermKey courseTerm) favourites
-      favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
+      favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, [(MenuItem, Text)], FavouriteReason)]
-      favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
+      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'
+      (caseChanged `on` unSchoolKey) ssh ssh'
-      return $ TermSchoolCourseListR tid 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
+      CourseR tid ssh csh _ <- return route
-      Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
-      hasChanged csh courseShorthand
+      caseChanged csh courseShorthand
-      (hasChanged `on` unSchoolKey) ssh courseSchool
+      return $ route & typesUsing @RouteChildren @CourseShorthand . filtered (== csh) .~ courseShorthand
-      return $ CourseR tid courseSchool courseShorthand subRoute
     ncSheet = maybeOrig $ \route -> do
-      CSheetR tid ssh csh shn subRoute <- return route
+      CSheetR tid ssh csh shn _ <- return route
-      Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
+      Entity cid Course{..} <- MaybeT . $cachedHereBinary (tid, ssh, csh) . lift . getBy $ TermSchoolCourseShort tid ssh csh
-      Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
+      Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . lift . getBy $ CourseSheet cid shn
-      hasChanged shn sheetName
+      caseChanged shn sheetName
-      return $ CSheetR tid ssh csh sheetName subRoute
+      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
+      sId <- $cachedHereBinary cID $ decrypt cID
-      Submission{submissionSheet}   <- lift . lift $ get404 sId
+      Submission{submissionSheet} <- MaybeT . $cachedHereBinary cID . lift $ get sId
-      Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
+      Sheet{sheetCourse, sheetName} <- MaybeT . $cachedHereBinary submissionSheet . lift $ get submissionSheet
-      Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
+      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

src/Handler/Allocation/Register.hs

@@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
       { allocationUserAllocation = aId
       , allocationUserUser = uid
       , allocationUserTotalCourses = arfTotalCourses
+      , allocationUserPriority = Nothing
       }
       [ AllocationUserTotalCourses =. arfTotalCourses
       ]

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
+  (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
-    alloc@(Entity aId _) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
+    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

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"

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

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{..}

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

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

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)
+  }

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

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

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

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
 

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{..} -> (,)
+  mAllocation' <- for mAllocation $ \alloc@Allocation{..} -> (,)
-    <$> pure allocationName
+    <$> 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")

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
+    (BtnCourseDeregister, mbReason)
-      | Just (Entity pId _) <- mRegistration
+      | 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

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
+                       , Ord act, PathPiece act, RenderMessage UniWorX act
-                       , RenderMessage UniWorX (Element acts), Eq (Element acts), PathPiece (Element acts)
                        )
                     => 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)))
+                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData)))
-                    -> PSValidator (MForm Handler) (FormResult (First (Element acts), DBFormResult UserId Bool UserTableData))
+                    -> PSValidator (MForm Handler) (FormResult (First act', DBFormResult UserId Bool UserTableData))
-                    -> DB (FormResult (Element acts, Set UserId), Widget)
+                    -> 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
+        acts = mconcat
-          [ Just CourseUserSendMail
+          [ singletonMap CourseUserSendMail $ pure CourseUserSendMailData
-          , guardOn mayRegister CourseUserDeregister
+          , 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
+    (CourseUserDeregisterData{..}, selectedUsers) -> do
-        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> do
+        Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
-          nrDel <- deleteWhereCount
+          now <- liftIO getCurrentTime
-            [ CourseParticipantCourse ==. cid
+          Entity reg CourseParticipant{..} <- MaybeT . getBy $ UniqueParticipant uid cid
-            , CourseParticipantUser ==. uid
+          lift $ delete reg
-            ]
+          lift . audit $ TransactionCourseParticipantDeleted cid uid
-          unless (nrDel == 0) $
+          case deregisterReason of
-            audit $ TransactionCourseParticipantDeleted cid uid
+            Just reason
-          return $ Sum nrDel
+              | 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}|]

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

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

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

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

src/Handler/Profile.hs

@@ -29,16 +29,17 @@ import Jobs
 
 
 data SettingsForm = SettingsForm
-      { stgDisplayName   :: UserDisplayName
+      { stgDisplayName          :: UserDisplayName
-      , stgDisplayEmail  :: UserEmail
+      , stgDisplayEmail         :: UserEmail
-      , stgMaxFavourties :: Int
+      , stgMaxFavourites        :: Int
-      , stgTheme         :: Theme
+      , stgMaxFavouriteTerms    :: Int
-      , stgDateTime      :: DateTimeFormat
+      , stgTheme                :: Theme
-      , stgDate          :: DateTimeFormat
+      , stgDateTime             :: DateTimeFormat
-      , stgTime          :: DateTimeFormat
+      , stgDate                 :: DateTimeFormat
-      , stgDownloadFiles :: Bool
+      , stgTime                 :: DateTimeFormat
-      , stgWarningDays   :: NominalDiffTime
+      , stgDownloadFiles        :: Bool
-      , stgSchools       :: Set SchoolId
+      , 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
+        <*> areq (natFieldI $ MsgNatField "Favoriten")
-            (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+            (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
+        { stgDisplayName          = userDisplayName
-        , stgDisplayEmail  = userDisplayEmail
+        , stgDisplayEmail         = userDisplayEmail
-        , stgMaxFavourties = userMaxFavourites
+        , stgMaxFavourites        = userMaxFavourites
-        , stgTheme         = userTheme
+        , stgMaxFavouriteTerms    = userMaxFavouriteTerms
-        , stgDateTime      = userDateTimeFormat
+        , stgTheme                = userTheme
-        , stgDate          = userDateFormat
+        , stgDateTime             = userDateTimeFormat
-        , stgTime          = userTimeFormat
+        , stgDate                 = userDateFormat
-        , stgDownloadFiles = userDownloadFiles
+        , stgTime                 = userTimeFormat
-        , stgSchools       = userSchools
+        , 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
+        [ UserDisplayName          =. stgDisplayName
-        , UserMaxFavourites  =. stgMaxFavourties
+        , UserMaxFavourites        =. stgMaxFavourites
-        , UserTheme          =. stgTheme
+        , UserMaxFavouriteTerms    =. stgMaxFavouriteTerms
-        , UserDateTimeFormat =. stgDateTime
+        , UserTheme                =. stgTheme
-        , UserDateFormat     =. stgDate
+        , UserDateTimeFormat       =. stgDateTime
-        , UserTimeFormat     =. stgTime
+        , UserDateFormat           =. stgDate
-        , UserDownloadFiles  =. stgDownloadFiles
+        , UserTimeFormat           =. stgTime
-        , UserWarningDays    =. stgWarningDays
+        , 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

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

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

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

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

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

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"

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

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

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

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

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

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"
+    )
   ]
 
 

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

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)

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)

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)

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

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"
 

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

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)

src/Utils/Form.hs

@@ -196,6 +196,7 @@ data FormIdentifier
   | FIDcourseRegister
   | FIDsheet
   | FIDmaterial
+  | FIDCourseNews
   | FIDsubmission
   | FIDsettings
   | FIDcorrectors

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

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

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

templates/allocation/show.hamlet

@@ -1,13 +1,24 @@
 $newline never
 <section>
-  $# <h2>
-  $#   _{MsgAllocationData}
   <dl .deflist>
+    <dt .deflist__dt>
+      _{MsgAllocationSemester}
+    <dd .deflist__dd>
+      _{unTermKey allocationTerm}
+    <dt .deflist__dt>
+      _{MsgAllocationSchool}
+    <dd .deflist__dd>
+      #{schoolName}
     $maybe desc <- allocationDescription
       <dt .deflist__dt>
         _{MsgAllocationDescription}
       <dd .deflist__dd>
         #{desc}
+    $maybe desc <- guardOn isAnyLecturer =<< allocationStaffDescription
+      <dt .deflist__dt>
+        _{MsgAllocationStaffDescription}
+      <dd .deflist__dd>
+        #{desc}
     $maybe fromT <- allocationStaffRegisterFrom
       <dt .deflist__dt>
         $maybe _ <- allocationStaffRegisterTo
@@ -32,14 +43,36 @@ $newline never
           _{MsgAllocationStaffAllocationFrom}
       <dd .deflist__dd>
         ^{formatTimeRangeW SelFormatDateTime fromT allocationStaffAllocationTo}
-
+    $maybe fromT <- allocationRegisterByStaffFrom
-    $# TODO show datetime of automatic allocation
+      <dt .deflist__dt>
-    $#
+        $maybe _ <- allocationRegisterByStaffTo
-    $#  <dt .deflist__dt>
+          _{MsgAllocationRegisterByStaff}
-    $#    _{MsgAllocationProcess}
+          <span .tooltip>
-    $#  <dd .deflist__dd>
+            <span .tooltip__handle>
-    $#    ^{formatTimeRangeW SelFormatDateTime fromT allocationProcess}
+            <span .tooltip__content>
-    $#
+                _{MsgAllocationRegisterByStaffTip}
+        $nothing
+          _{MsgAllocationRegisterByStaffFrom}
+          <span .tooltip>
+            <span .tooltip__handle>
+            <span .tooltip__content>
+                _{MsgAllocationRegisterByStaffFromTip}
+      <dd .deflist__dd>
+        ^{formatTimeRangeW SelFormatDateTime fromT allocationRegisterByStaffTo}
+    $maybe fromT <- allocationRegisterByCourse
+      <dt .deflist__dt>
+        _{MsgAllocationRegisterByCourseFrom}
+        <span .tooltip>
+          <span .tooltip__handle>
+          <span .tooltip__content>
+            _{MsgAllocationRegisterByCourseFromTip}
+      <dd .deflist__dd>
+        ^{formatTimeW SelFormatDateTime fromT}
+    $maybe toT <- allocationOverrideDeregister
+      <dt .deflist__dt>
+        _{MsgAllocationOverrideDeregister}
+      <dd .deflist__dd>
+        <p>^{formatTimeW SelFormatDateTime toT}
 
 <section id=allocation-participation>
   <h2>

templates/allocation/show.lucius

@@ -17,10 +17,11 @@
   display: grid;
   grid-template-columns: minmax(105px, 1fr) 9fr;
   grid-template-areas:
-    'name        name   '
+    'name        name       '
-    'prio-label  prio   '
+    '.           registered '
-    'instr-label instr  '
+    'prio-label  prio       '
-    'form-label  form   ';
+    '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'

templates/allocation/show/course.hamlet

@@ -1,3 +1,7 @@
+$if isRegistered
+  <div .allocation-course__registered>
+    #{iconOK}
+    \ _{MsgRegistered}
 $if is _Just muid
   <div .allocation-course__priority-label .allocation__label>
     _{MsgAllocationPriority}

templates/course-news.hamlet

@@ -0,0 +1,12 @@
+$newline never
+$maybe summary <- courseNewsSummary
+  <section>
+    <dl .deflist>
+      <dt .deflist__dt>
+        _{MsgCourseNewsSummary}
+      <dd .deflist__dd>
+        #{summary}
+  <section>
+    #{courseNewsContent}
+$nothing
+  #{courseNewsContent}

templates/course.hamlet

@@ -1,16 +1,78 @@
 $newline never
 <dl .deflist>
-  <dt .deflist__dt>Fakultät/Institut
+  $if not (null news) || mayCreateNews
-  <dd .deflist__dd>
+    <dt .deflist__dt>
-    <div>
+      _{MsgCourseNews}
-      #{schoolName}
+      $if not visibleNews
-
+        \ #{iconInvisible}
+    <dd .deflist__dd>
+      $if not (null news)
+        <ul .course-news .list--iconless>
+          $forall (cID, CourseNews{courseNewsTitle, courseNewsSummary, courseNewsContent}, isVisible, files, lastEditText, mayEdit, mayDelete) <- news
+            <li .course-news-item ##{"news-" <> toPathPiece cID}>
+              $case (courseNewsTitle, courseNewsSummary)
+$#                 $of (Just title, Just summary)
+$#                   <div .div-h3 .course-news-item__title>
+$#                     ^{modal (toWidget title) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
+$#                     $if not isVisible
+$#                       \ #{iconInvisible}
+$#                   <p .course-news-item__summary>
+$#                     #{summary}
+                $of (_, Just summary)
+                  $if not isVisible
+                    <h3 .course-news-item__title>
+                      #{iconInvisible}
+                  <div .div-p .course-news-item__summary>
+                    ^{modal (toWidget summary) (Left (SomeRoute (CNewsR tid ssh csh cID CNShowR)))}
+                $of (Just title, Nothing)
+                  <h3 .course-news-item__title>
+                    #{title}
+                    $if not isVisible
+                      \ #{iconInvisible}
+                  <p .course-news-item__content>
+                    #{courseNewsContent}
+                $of (Nothing, Nothing)
+                  $if not isVisible
+                    <h3 .course-news-item__title>
+                      #{iconInvisible}
+                  <p .course-news-item__content>
+                    #{courseNewsContent}
+              $if showNewsFiles files
+                <ul .course-news-item__files-links .list--inline .list--comma-separated>
+                  $forall (_, fp) <- filter (not . view _1) files
+                    <li .course-news-item__file-link>
+                      <a href=@{CNewsR tid ssh csh cID (CNFileR fp)}>
+                        #{fp}
+              $elseif not (null files)
+                <p .course-news-item__files-link>
+                  <a href=@{CNewsR tid ssh csh cID CNArchiveR}>
+                    #{iconFileZip}
+                    \ _{MsgCourseNewsFiles}
+              <p .course-news-item__last-edit>
+                _{MsgCourseNewsLastEdited lastEditText}
+              $if mayEdit || mayDelete
+                <ul .course-news-item__actions .list--inline .list--comma-separated>
+                  $if mayEdit
+                    <li>
+                      ^{modal (i18n MsgCourseNewsActionEdit) (Left (SomeRoute (CNewsR tid ssh csh cID CNEditR)))}
+                  $if mayDelete
+                    <li>
+                      ^{modal (i18n MsgCourseNewsActionDelete) (Left (SomeRoute (CNewsR tid ssh csh cID CNDeleteR)))}
+      $if mayCreateNews
+        <div .div-p>
+          ^{modal (i18n MsgCourseNewsActionCreate) (Left (SomeRoute (CourseR tid ssh csh CNewsNewR)))}
+            
+  
   $maybe descr <- courseDescription course
     <dt .deflist__dt>_{MsgCourseDescription}
     <dd .deflist__dd>
       <div>
         #{descr}
 
+  <dt .deflist__dt>_{MsgCourseSchool}
+  <dd .deflist__dd>
+    #{schoolName}
+
   $with numlecs <- length lecturers
     $if numlecs /= 0
       $if numlecs > 1
@@ -18,10 +80,9 @@ $newline never
       $else
         <dt .deflist__dt>_{MsgLecturerFor}
       <dd .deflist__dd>
-        <div>
+        <ul .list--inline .list--comma-separated>
-          <ul .list--inline .list--comma-separated>
+          $forall lect <- lecturers
-            $forall lect <- lecturers
+            <li>^{nameEmailWidget' lect}
-              <li>^{nameEmailWidget' lect}
   $with numassi <- length assistants
     $if numassi /= 0
       $if numassi > 1
@@ -29,58 +90,64 @@ $newline never
       $else
         <dt .deflist__dt>_{MsgAssistantFor}
       <dd .deflist__dd>
-        <div>
+        <ul .list--inline .list--comma-separated>
-          <ul .list--inline .list--comma-separated>
+          $forall assi <- assistants
-            $forall assi <- assistants
+            <li>^{nameEmailWidget' assi}
-              <li>^{nameEmailWidget' assi}
 
   $with numtutor <- length tutors
     $if numtutor /= 0
       <dt .deflist__dt>_{MsgTutorsFor numtutor}
       <dd .deflist__dd>
-        <div>
+        <ul .list--inline .list--comma-separated>
-          <ul .list--inline .list--comma-separated>
+          $forall tutor <- tutors
-            $forall tutor <- tutors
+            <li>^{nameEmailWidget' tutor}
-              <li>^{nameEmailWidget' tutor}
 
   $with numcorrector <- length correctors
     $if numcorrector /= 0
       <dt .deflist__dt>_{MsgCorrectorsFor numcorrector}
       <dd .deflist__dd>
-        <div>
+        <ul .list--inline .list--comma-separated>
-          <ul .list--inline .list--comma-separated>
+          $forall corrector <- correctors
-            $forall corrector <- correctors
+            <li>^{nameEmailWidget' corrector}
-              <li>^{nameEmailWidget' corrector}
 
   $maybe link <- courseLinkExternal course
-    <dt .deflist__dt>Website
+    <dt .deflist__dt>_{MsgCourseHomepageExternal}
     <dd .deflist__dd>
-      <div>
+      <a href=#{link} target="_blank" rel="noopener" title="_{MsgCourseHomepageExternal}">
-        <a href=#{link} target="_blank" rel="noopener" title="Website des Kurses">#{link}
+        #{iconLink}
+        \ #{link}
 $#    $if NTop (Just 0) < NTop (courseCapacity course)
-  <dt .deflist__dt>Teilnehmer
+  <dt .deflist__dt>_{MsgCourseParticipantsHeading}
   <dd .deflist__dd>
-      <div>
+    $maybe capacity <- courseCapacity course
-        #{participants}
+      _{MsgCourseParticipantsCountOf participants capacity}
-        $maybe capacity <- courseCapacity course
+    $nothing
-          \ von #{capacity}
+      _{MsgCourseParticipantsCount participants}
-  $maybe (name, url) <- mAllocation'
+  $maybe (Allocation{allocationName, allocationRegisterByCourse}, url) <- mAllocation'
     <dt .deflist__dt>_{MsgCourseAllocation}
     <dd .deflist__dd>
       <a href=#{url}>
-        #{name}
+        #{allocationName}
+    $maybe regFrom <- allocationRegisterByCourse
+      $maybe regFrom' <- courseRegisterFrom course
+        $with regFrom'' <- max regFrom regFrom'
+          $if NTop (Just regFrom'') <= NTop (courseRegisterTo course)
+            <dt .deflist__dt>_{MsgCourseDirectRegistrationInterval}
+            <dd .deflist__dd>
+              <p>
+                ^{formatTimeRangeW SelFormatDateTime regFrom'' (courseRegisterTo course)}
+              $maybe dereg <- mDereg
+                <p .emph>
+                  _{MsgCourseDeregisterUntil dereg}
   $nothing
-    $maybe regFrom <- mRegFrom
+    $maybe regFrom <- courseRegisterFrom course
-      <dt .deflist__dt>Anmeldezeitraum
+      <dt .deflist__dt>_{MsgCourseRegistrationInterval}
       <dd .deflist__dd>
-        <div>
+        <p>
-          Ab #{regFrom}
+          ^{formatTimeRangeW SelFormatDateTime regFrom (courseRegisterTo course)}
-          $maybe regTo <- mRegTo
-            \ bis #{regTo}
         $maybe dereg <- mDereg
-          <div>
+          <p .emph>
-            \ <em>Achtung:</em>
+            _{MsgCourseDeregisterUntil dereg}
-            \ Abmeldung nur bis #{dereg} erlaubt.
   $maybe aInst <- courseApplicationsInstructions course
     <dt .deflist__dt>
       $if courseApplicationsRequired course
@@ -98,7 +165,7 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
               _{MsgCourseApplicationTemplateApplication}
             $else
               _{MsgCourseApplicationTemplateRegistration}
-  $if registrationOpen || isJust mRegAt
+  $if registrationOpen || isJust registration
     <dt .deflist__dt>
       _{MsgCourseRegistration}
     <dd .deflist__dd>
@@ -110,20 +177,19 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
             <p>
               _{MsgCourseApplicationDeleteToEdit}
           $else
-            $if isJust mRegAt
+            $if isJust registration
               <p>
                 _{MsgCourseRegistrationDeleteToEdit}
-        $maybe date <- mRegAt
+        $maybe CourseParticipant{courseParticipantRegistration} <- registration
-          _{MsgRegisteredSince} #{date}
+          _{MsgRegisteredSince}
+          \ ^{formatTimeW SelFormatDateTime courseParticipantRegistration}
   <dt .deflist__dt>
-    Material
+    _{MsgCourseMaterial}
   <dd .deflist__dd>
-    <div>
+    $if courseMaterialFree course
-      $if courseMaterialFree course
+      _{MsgCourseMaterialFree}
-        Das Kursmaterial ist ohne Anmeldung frei zugänglich.
+    $else
-      $else
+      _{MsgCourseMaterialNotFree}
-        Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial
-        (z.B. Übungsblätter).
   $if hasExams
     <dt .deflist__dt>_{MsgCourseExams}
     <dd .deflist__dd>

templates/course.lucius

@@ -6,3 +6,37 @@ th {
 th, td {
   padding-bottom: 7px;
 }
+
+.course-news {
+    max-height: 50vh;
+    overflow: auto;
+     
+    .course-news-item {
+        padding: 12px 0;
+        border-bottom: 1px solid #d3d3d3;
+
+        &:last-child {
+            padding-bottom: 0;
+            border-bottom: none;
+        }
+        
+        &:first-child {
+            padding-top: 0;
+        }
+
+        .course-news-item__last-edit {
+            color: var(--color-fontsec);
+            font-style: italic;
+        }
+
+        .course-news-item__title .modal__trigger-label {
+            font-style: normal;
+        }
+
+        .course-news-item__summary .modal__trigger-label {
+            font-weight: normal;
+            font-style: normal;
+            color: var(--color-font);
+        }
+    }
+}

templates/default-layout.lucius

@@ -108,6 +108,10 @@ body {
 
 /* END THEMES */
 
+.emph {
+  font-style: italic;
+}
+
 a,
 a:visited {
   text-decoration: none;
@@ -128,7 +132,7 @@ ul {
   margin-left: 20px;
 }
 
-h1, h2, h3, h4, h5 {
+h1, h2, h3, .div-h3 , h4, h5 {
   font-weight: 600;
 }
 h1 {
@@ -138,10 +142,18 @@ h1 {
 h2 {
   font-size: 24px;
   margin: 10px 0;
+
+  &:first-child {
+    margin-top: 0;
+  }
 }
-h3 {
+h3, .div-h3 {
   font-size: 20px;
   margin: 10px 0;
+
+  &:first-child {
+    margin-top: 0;
+  }
 }
 h4 {
   font-size: 16px;
@@ -158,7 +170,7 @@ h4 {
     font-size: 20px;
   }
 
-  h3 {
+  h3, .div-h3 {
     font-size: 16px;
   }
 }
@@ -185,7 +197,7 @@ h4 {
     text-decoration: underline;
   }
 
-  p, form {
+  p, form, .div-p {
     margin: 0.5rem 0;
 
     &:last-child {
@@ -538,7 +550,7 @@ ul.list--inline {
   font-size: 18px;
   margin-bottom: 10px;
 
-  > p {
+  > p, > .div-p {
     margin-top: 0;
   }
 }
@@ -647,6 +659,13 @@ section {
   grid-template-columns: 1fr 3fr;
   grid-gap: 5px;
 
+  fieldset {
+    display: grid;
+    grid-template-columns: 1fr 3fr;
+    grid-gap: 5px;
+    grid-column: 1/3;
+  }
+
   .notification {
     margin: 0;
   }
@@ -664,6 +683,11 @@ section {
   .form-section-notification {
     grid-template-columns: 1fr;
     margin-top: 17px;
+
+    fieldset {
+      grid-template-columns: 1fr;
+      grid-column: 1/2;
+    }
   }
 
   .notification {

templates/i18n/allocation-info/de.hamlet

@@ -29,12 +29,13 @@ $newline text
         Studierende können sich nur in diesem Zeitraum
         auf Plätze in Kursen einer Zentralanmeldung bewerben.
       <p>
-        Bewerber können jedem Kurs der Zentralanmeldung eine Priorität
+        Bewerber können jedem Kurs der Zentralanmeldung eine Priorität zuweisen,
-        zuweisen, zwischen "dieser Kurs wäre meine erste Wahl"
+        zwischen "dieser Kurs wäre meine erste Wahl" und "diesen Kurs besuche
-        und "diesen Kurs besuche ich auf keinen Fall".
+        ich nur, wenn ich keinen anderen Platz kriege".
         Es kann auch mehreren Kursen die gleiche Priorität eingeräumt werden.
       <p>
-        Bewerbungen für und Prioritisierung der Kurse können innerhalb des Bewerbungszeitraums beliebig angepasst und zurückgezogen werden.
+        Bewerbungen für und Prioritisierung der Kurse können innerhalb des
+        Bewerbungszeitraums beliebig angepasst und zurückgezogen werden.
       <p>
         Studierende können auch mehr als einen Platz
         in verschiedenen Kursen einer Zentralanmeldung anfordern,
@@ -64,7 +65,6 @@ $newline text
         und der Bewertung durch den Veranstalter auf die Bewerber verteilt.
       <p>
         Die Bewerber werden diekt in den jeweiligen Kursen angemeldet.
-        Eine Abmeldung durch Studierende ist nicht erlaubt.
         Übernommene Bewerber, welche einen zugeteilten Platz
         ohne Angabe eines triftigen Grundes nicht antreten,
         werden in zukünftigen Zentralanmeldungen
@@ -78,9 +78,8 @@ $newline text
     Der Ablauf einer Zentralanmeldung kann unter Umständen noch variieren.
     <em>
       Insbesondere: #
-    Fehlt in der Übersichtsseite einer Zentralanmeldung
+    Fehlt in der Übersichtsseite einer Zentralanmeldung die Angabe einer dieser
-    die Angabe einer dieser Phasen, dann wurde der entsprechende Zeitraum
+    Phasen, dann wurden die entsprechenden Zeiten noch nicht festgelegt!
-    leider noch nicht festgelegt!
   <p>
     Mehrere Zentralanmeldungen werden völlig unabhängig voneinander
     abgewickelt.

templates/i18n/changelog/de.hamlet

@@ -1,5 +1,11 @@
 $newline never
 <dl .deflist>
+  <dt .deflist__dt>
+    ^{formatGregorianW 2019 10 01}
+  <dd .deflist__dd>
+    <ul>
+      <li>"Aktuelles" für Kurse
+
   <dt .deflist__dt>
     ^{formatGregorianW 2019 09 27}
   <dd .deflist__dd>

templates/i18n/info-lecturer/de.hamlet

@@ -97,6 +97,15 @@ $newline text
           <a href=@{AuthPredsR}>Berechtigungen hier temporär selbst entziehen
         . Um die eigene Veranstaltung aus Sicht eines Teilnehmers zu sehen, deaktiviert man #
         die Berechtigungsprüfungen "_{MsgAuthTagLecturer}" und/oder "_{MsgAuthTagCorrector}"
+  
+    <dt .deflist__dt> Aktuelles
+    <dd .deflist__dd>
+      <p>
+        Es lassen sich, direkt auf der Kursübersichtsseite, Neuigkeiten in Bezug
+        auf die Veranstaltung auf der Übersichtsseite publizieren ("Aktuelles").
+      <p>
+        In Zukunft sind ein RSS-Feed und (opt-in) E-Mail-Benachrichtigungen
+        hierfür geplant.
 
 <section>
   <h2>Übungsbetrieb

templates/mail/allocationResults.hamlet

@@ -0,0 +1,36 @@
+$newline never
+\<!doctype html>
+<html>
+  <head>
+    <meta charset="UTF-8">
+    <style>
+      h1 {
+        font-size: 1.25em;
+        font-variant: small-caps;
+        font-weight: normal;
+      }
+  <body>
+    <h1>
+      _{SomeMessage $ MsgMailSubjectAllocationResults allocationName}
+
+    $if not (null lecturerResults)
+      <p>
+        _{SomeMessage MsgAllocationResultsLecturer}
+      <ul>
+        $forall msg <- lecturerResults
+          <li>_{msg}
+
+    $maybe pResults <- participantResults
+      $case pResults 
+        $of []
+          <p>_{SomeMessage MsgAllocationNoResultsStudent}
+        $of [csh]
+          <p>_{SomeMessage $ MsgAllocationResultStudent csh}
+        $of cshs
+          <p>
+            _{SomeMessage MsgAllocationResultsStudent}
+          <ul>
+            $forall csh <- cshs
+              <li>#{csh}
+
+    ^{ihamletSomeMessage editNotifications}

templates/widgets/asidenav/asidenav.hamlet

@@ -12,20 +12,24 @@ $newline never
       <div .asidenav__box>
         <h3 .asidenav__box-title uw-show-hide data-show-hide-id="#{termToText tid}" data-show-hide-align=right>
           _{ShortTermIdentifier tid}
-        <ul .asidenav__list.list--iconless>
+        $forall favReason <- sortOn Down universeF
-          $forall (Course{courseShorthand, courseName}, courseRoute, pageActions) <- favouriteTerm tid
+          $if not (null $ favouriteTermReason tid favReason)
-            <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
+            <h3 .asidenav__box-subtitle>
-              <a .asidenav__link-wrapper href=@{courseRoute}>
+              _{favReason}
-                <div .asidenav__link-shorthand>#{courseShorthand}
+            <ul .asidenav__list.list--iconless>
-                <div .asidenav__link-label>#{courseName}
+              $forall (Course{courseShorthand, courseName}, courseRoute, pageActions, _) <- favouriteTermReason tid favReason
-              <div .asidenav__nested-list-wrapper>
+                <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
-                <ul .asidenav__nested-list.list--iconless>
+                  <a .asidenav__link-wrapper href=@{courseRoute}>
-                  $forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
+                    <div .asidenav__link-shorthand>#{courseShorthand}
-                    $case menuItemType
+                    <div .asidenav__link-label>#{courseName}
-                      $of PageActionPrime
+                  <div .asidenav__nested-list-wrapper>
-                        <li .asidenav__nested-list-item>
+                    <ul .asidenav__nested-list.list--iconless>
-                          <a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
+                      $forall (MenuItem{menuItemType, menuItemLabel}, route) <- pageActions
-                      $of _
+                        $case menuItemType
+                          $of PageActionPrime
+                            <li .asidenav__nested-list-item>
+                              <a .asidenav__link-wrapper href=#{route}>_{menuItemLabel}
+                          $of _
 
     <div .asidenav__sigillum>
       <img src=@{StaticR img_lmu_sigillum_svg}>

templates/widgets/delete-confirmation/delete-confirmation.hamlet

@@ -1,10 +1,21 @@
-<p>_{drCaption}
+$newline never
-<ul>
-  $forall (wdgt, _) <- targets
-    <li>
-      ^{wdgt}
 
-<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
+<p>_{drCaption}
+
+$case targets
+  $of [(wdgt, _)]
+    <p>^{wdgt}
+  $of _
+    <ul>
+      $forall (wdgt, _) <- targets
+        <li>
+          ^{wdgt}
+
+<p>
+  $if Text.null (Text.strip confirmString)
+    _{SomeMessage $ MsgDeletePressButtonIfSure (Set.size drRecords)}
+  $else
+    _{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
 
 <p .confirmationText>
   #{confirmString}

test/Database.hs

@@ -101,6 +101,7 @@ fillDb = do
     , userFirstName = "Gregor Julius Arthur"
     , userTitle = Nothing
     , userMaxFavourites = 6
+    , userMaxFavouriteTerms = 1
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
@@ -126,6 +127,7 @@ fillDb = do
     , userFirstName = "Felix"
     , userTitle = Nothing
     , userMaxFavourites = userDefaultMaxFavourites
+    , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
     , userTheme = ThemeDefault
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
@@ -151,6 +153,7 @@ fillDb = do
     , userFirstName = "Steffen"
     , userTitle = Just "Dr."
     , userMaxFavourites = 14
+    , userMaxFavouriteTerms = 4
     , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
@@ -178,6 +181,7 @@ fillDb = do
     , userMaxFavourites = 7
     , userTheme = ThemeAberdeenReds
     , userDateTimeFormat = userDefaultDateTimeFormat
+    , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
     , userDateFormat = userDefaultDateFormat
     , userTimeFormat = userDefaultTimeFormat
     , userDownloadFiles = userDefaultDownloadFiles
@@ -201,6 +205,7 @@ fillDb = do
     , userFirstName = "Sabrina"
     , userTitle = Just "Magister"
     , userMaxFavourites = 5
+    , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
     , userTheme = ThemeAberdeenReds
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
@@ -226,6 +231,7 @@ fillDb = do
     , userFirstName = "Sarah"
     , userTitle = Nothing
     , userMaxFavourites = 14
+    , userMaxFavouriteTerms = 4
     , userTheme = ThemeMossGreen
     , userDateTimeFormat = userDefaultDateTimeFormat
     , userDateFormat = userDefaultDateFormat
@@ -469,7 +475,7 @@ fillDb = do
   insert_ $ SheetEdit gkleen now feste
   keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
   insert_ $ SheetEdit gkleen now keine
-  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMs)
     ,(tinaTester, Just sfTTc)
@@ -592,7 +598,7 @@ fillDb = do
   insert_ $ CourseEdit jost now pmo
   void . insert $ DegreeCourse pmo sdBsc sdInf
   void . insert $ Lecturer jost pmo CourseAssistant
-  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
+  void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing)
     [(fhamann   , Nothing)
     ,(maxMuster , Just sfMMp)
     ,(tinaTester, Just sfTTb)
@@ -779,6 +785,8 @@ fillDb = do
     , allocationRegisterByStaffTo = Nothing
     , allocationRegisterByCourse = Nothing
     , allocationOverrideDeregister = Just now
+    , allocationFingerprint = Nothing
+    , allocationMatchingLog = Nothing
     }
   insert_ $ AllocationCourse funAlloc pmo 100
   insert_ $ AllocationCourse funAlloc ffp 2

test/FoundationSpec.hs

@@ -65,6 +65,10 @@ instance Arbitrary ExamOfficeR where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
+instance Arbitrary CourseNewsR where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
 instance Arbitrary (Route UniWorX) where
   arbitrary = genericArbitrary
   shrink = genericShrink

test/ModelSpec.hs

@@ -92,6 +92,7 @@ instance Arbitrary User where
     userTitle <- fmap (pack . getPrintableString) <$> arbitrary
 
     userMaxFavourites <- getNonNegative <$> arbitrary
+    userMaxFavouriteTerms <- getNonNegative <$> arbitrary
     userTheme <- arbitrary
 
     let genDateTimeFormat sel = do

test/TestImport.hs

@@ -131,6 +131,7 @@ createUser adjUser = do
     userTitle = Nothing
     userTheme = userDefaultTheme
     userMaxFavourites = userDefaultMaxFavourites
+    userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
     userDateTimeFormat = userDefaultDateTimeFormat
     userDateFormat = userDefaultDateFormat
     userTimeFormat = userDefaultTimeFormat

test/Utils/AllocationSpec.hs

@@ -0,0 +1,160 @@
+module Utils.AllocationSpec where
+
+import TestImport hiding (Course)
+
+import Utils.Allocation
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import System.Random (mkStdGen)
+
+
+data Man = Alpha | Beta | Gamma | Delta
+  deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
+instance NFData Man
+
+data Woman = Alef | Bet | Gimel | Dalet
+  deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
+  
+
+spec :: Spec
+spec = describe "computeMatching" $
+  it "produces some expected known matchings" $ do
+    example $ do
+      let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma]
+          women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
+          preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
+            [ ((Alpha, Alef ), (1, 3))
+            , ((Alpha, Bet  ), (2, 2))
+            , ((Alpha, Gimel), (3, 1))
+            , ((Beta , Alef ), (3, 1))
+            , ((Beta , Bet  ), (1, 3))
+            , ((Beta , Gimel), (2, 2))
+            , ((Gamma, Alef ), (2, 2))
+            , ((Gamma, Bet  ), (3, 1))
+            , ((Gamma, Gimel), (1, 3))
+            ]
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)]
+          ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
+      ourResult `shouldBe` expectedResult
+
+    example $ do
+      let men = Map.fromList $ (, 2) <$> [Alpha,Beta,Delta]
+          women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
+          preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
+            [ ((Alpha, Alef ), (1, 3))
+            , ((Alpha, Bet  ), (2, 2))
+            , ((Alpha, Gimel), (3, 1))
+            , ((Beta , Alef ), (3, 1))
+            , ((Beta , Bet  ), (1, 3))
+            , ((Beta , Gimel), (2, 2))
+            , ((Delta, Alef ), (2, 2))
+            , ((Delta, Bet  ), (3, 1))
+            , ((Delta, Gimel), (1, 3))
+            ]
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Delta, Gimel)]
+          ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
+      ourResult `shouldBe` expectedResult
+  
+    example $ do
+      let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma]
+          women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel]
+          preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
+            [ ((Alpha, Alef ), (1, 3))
+            , ((Alpha, Bet  ), (2, 2))
+            , ((Alpha, Gimel), (3, 1))
+            , ((Beta , Alef ), (3, 1))
+            , ((Beta , Bet  ), (1, 3))
+            , ((Beta , Gimel), (2, 2))
+            , ((Gamma, Alef ), (2, 2))
+            , ((Gamma, Bet  ), (3, 1))
+            , ((Gamma, Gimel), (1, 3))
+            ]
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(Alpha, Alef), (Gamma, Alef), (Beta, Bet), (Alpha, Bet), (Beta, Gimel), (Gamma, Gimel)]
+          ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
+      ourResult `shouldBe` expectedResult
+ 
+    example $ do
+      let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
+          women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
+          preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
+            [ ((Alpha, Alef ), (1, 3))
+            , ((Alpha, Bet  ), (2, 3))
+            , ((Alpha, Gimel), (3, 2))
+            , ((Alpha, Dalet), (4, 3))
+            , ((Beta , Alef ), (1, 4))
+            , ((Beta , Bet  ), (4, 1))
+            , ((Beta , Gimel), (3, 3))
+            , ((Beta , Dalet), (2, 2))
+            , ((Gamma, Alef ), (2, 2))
+            , ((Gamma, Bet  ), (1, 4))
+            , ((Gamma, Gimel), (3, 4))
+            , ((Gamma, Dalet), (4, 1))
+            , ((Delta, Alef ), (4, 1))
+            , ((Delta, Bet  ), (2, 2))
+            , ((Delta, Gimel), (3, 1))
+            , ((Delta, Dalet), (1, 4))
+            ]
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
+          ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
+      ourResult `shouldBe` expectedResult
+      
+    example $ do
+      let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
+          women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
+          preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
+            [ ((Alpha, Alef ), (1, 3))
+            , ((Alpha, Bet  ), (2, 2))
+            , ((Alpha, Gimel), (3, 1))
+            , ((Alpha, Dalet), (4, 3))
+            , ((Beta , Alef ), (1, 4))
+            , ((Beta , Bet  ), (2, 3))
+            , ((Beta , Gimel), (3, 2))
+            , ((Beta , Dalet), (4, 4))
+            , ((Gamma, Alef ), (3, 1))
+            , ((Gamma, Bet  ), (1, 4))
+            , ((Gamma, Gimel), (2, 3))
+            , ((Gamma, Dalet), (4, 2))
+            , ((Delta, Alef ), (2, 2))
+            , ((Delta, Bet  ), (3, 1))
+            , ((Delta, Gimel), (1, 4))
+            , ((Delta, Dalet), (4, 1))
+            ]
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
+          ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
+      ourResult `shouldBe` expectedResult
+      
+    example $ do
+      let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int])
+          colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char])
+          student_preferences = Map.fromList
+            [ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)
+            , ((2, 'A'), 3), ((2, 'Z'), 1), ((2, 'C'), 2)
+            , ((3, 'A'), 3), ((3, 'Z'), 2), ((3, 'C'), 1)
+            , ((4, 'A'), 2), ((4, 'Z'), 3), ((4, 'C'), 1)
+            , ((5, 'A'), 1), ((5, 'Z'), 3), ((5, 'C'), 2)
+            , ((6, 'A'), 2), ((6, 'Z'), 1), ((6, 'C'), 6)
+            ]
+          preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences
+
+          centralNudge _ _ = id
+
+          expectedResult = Set.fromList [(1, 'A'), (2, 'A'), (3, 'Z'), (4, 'Z'), (5, 'C'), (6, 'C')]
+          ourResult = computeMatching (mkStdGen 0) students colleges preferences centralNudge
+      ourResult `shouldBe` expectedResult