Merge branch 'master' into workflows

.hlint.yaml

@@ -12,6 +12,7 @@
   - ignore: { name: "Use ***" }
   - ignore: { name: "Redundant void" }
   - ignore: { name: "Too strict maybe" }
+  - ignore: { name: "Use Just" }
 
   - arguments:
       - -XQuasiQuotes

CHANGELOG.md

@@ -2,6 +2,24 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+## [20.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.1...v20.5.0) (2020-09-28)
+
+
+### Features
+
+* **allocations:** notify about new courses ([18921e0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/18921e06d1deeb41d705eabacc2d348bac76197f))
+* **allocations:** show staff descriptions ([b359468](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b35946859309fbb526043194c8620c5fc0844809))
+* **changelog:** implement changelog like faq ([d9d353f](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d9d353fcb7652c46a15016b5d2f400162c8271ef))
+* **exams:** check exam_discouraged_modes ([f9c50c8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f9c50c80f22770f5376396923b8921eaac3e7216))
+* **exams:** exam design & school exam rules ([f7bab3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f7bab3befc4c42cde430699681f8caf8a959ab39))
+
+
+### Bug Fixes
+
+* tests ([65e0688](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/65e06882d2491da5e30b1401db6ecc81efcac58b))
+* **allocations:** notify for new course upon registration ([9e0b43a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9e0b43a60d26a05f6e1b9d4dae2b2f75dd52fff1))
+* tests ([ca81f3b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca81f3b0f2913431cbaf399c33ed30a21979ce69))
+
 ### [20.4.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.4.0...v20.4.1) (2020-09-23)
 
 

frontend/src/app.sass

@@ -628,6 +628,11 @@ section
   &.notification--broad
     max-width: none
 
+  &:first-child
+    margin-top: 0
+  &:last-child
+    margin-bottom: 0
+
 .form-section-notification
   display: grid
   grid-template-columns: 1fr 3fr
@@ -1100,9 +1105,8 @@ th, td
           pointer-events: none
 
 #changelog
-  font-size: 14px
+  max-height: 75vh
-  white-space: pre-wrap
+  overflow: auto
-  font-family: var(--font-monospace)
 
 #gitrev
   font-size: 12px

messages/uniworx/de-de-formal.msg

@@ -790,6 +790,15 @@ FormBehaviour: Verhalten
 FormCosmetics: Oberfläche
 FormPersonalAppearance: Öffentliche Daten
 FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen
+FormAllocationNotifications: Benachrichtigungen für neue Zentralanmeldungskurse
+FormAllocationNotificationsTip: Wollen Sie eine Benachrichtigung per E-Mail erhalten wenn ein neuer Kurs zur Zentralanmeldung eingetragen wird? „Ja“ und „Nein“ überschreiben die entsprechende systemweite Einstellung unter "Benachrichtigungen"
+
+AllocNotifyNewCourseDefault: Systemweite Einstellung
+AllocNotifyNewCourseForceOff: Nein
+AllocNotifyNewCourseForceOn: Ja
+
+BtnNotifyNewCourseForceOn: Benachrichtigen
+BtnNotifyNewCourseForceOff: Nicht benachrichtigen
 
 PersonalInfoExamAchievementsWip: Die Anzeige von Prüfungsergebnissen wird momentan an dieser Stelle leider noch nicht unterstützt.
 PersonalInfoOwnTutorialsWip: Die Anzeige von Tutorien, zu denen Sie als Tutor eingetragen sind wird momentan an dieser Stelle leider noch nicht unterstützt.
@@ -1133,6 +1142,8 @@ NotificationTriggerCourseRegistered: Ein Kursverwalter hat mich zu einem Kurs an
 NotificationTriggerSubmissionUserCreated: Ich wurde als Mitabgebender zu einer Übungsblatt-Abgabe hinzugefügt
 NotificationTriggerSubmissionEdited: Eine meiner Übungsblatt-Abgaben wurde verändert
 NotificationTriggerSubmissionUserDeleted: Ich wurde als Mitabgebender von einer Übungsblatt-Abgabe entfernt
+NotificationTriggerAllocationNewCourse: Es wurde ein neuer Kurs eingetragen zu einer Zentralanmeldungen, zu der ich meine Teilnahme registriert habe
+NotificationTriggerAllocationNewCourseTip: Kann pro Zentralanmeldung überschrieben werden
 
 NotificationTriggerKindAll: Für alle Benutzer
 NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
@@ -1837,6 +1848,39 @@ ExamFormOccurrences: Prüfungstermine/Räume
 ExamFormAutomaticFunctions: Automatische Funktionen
 ExamFormCorrection: Korrektur
 ExamFormParts: Teile
+ExamFormMode: Ausgestaltung der Prüfung
+
+ExamModeFormNone: Keine Angabe
+ExamModeFormCustom: Benutzerdefiniert
+ExamModeFormAids: Erlaubte Hilfsmittel
+ExamModeFormOnline: Online/Offline
+ExamModeFormSynchronicity: Synchron/Asynchron
+ExamModeFormRequiredEquipment: Erforderliche Hilfsmittel
+ExamModeFormRequiredEquipmentIdentificationTip: Es wird stets ein Hinweis angezeigt, dass Teilnehmer sich ausweisen können müssen.
+
+ExamShowAids: Erlaubte Hilfsmittel
+ExamShowOnline: Online/Offline
+ExamShowSynchronicity: Synchron/Asynchron
+ExamShowRequiredEquipment: Erforderliche Hilfsmittel
+ExamShowRequiredEquipmentNoneSet: Keine Angabe durch die Kursverwalter
+ExamShowIdentificationRequired: Prüfungsteilnehmer müssen sich ausweisen können. Halten Sie dafür einen amtlichen Lichtbildausweis (Personalausweis, Reisepass, Aufenthaltstitel) und Ihren Studierendenausweis bereit.
+
+ExamOpenBook: Open Book
+ExamClosedBook: Closed Book
+
+ExamOnline: Online
+ExamOffline: Offline
+
+ExamSynchronous: Synchron
+ExamAsynchronous: Asynchron
+
+ExamRequiredEquipmentNone: Nichts
+ExamRequiredEquipmentPen: Stift
+ExamRequiredEquipmentPaperPen: Stift & Papier
+ExamRequiredEquipmentCalculatorPen: Stift & Taschenrechner
+ExamRequiredEquipmentCalculatorPaperPen: Stift, Papier & Taschenrechner
+ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & Mikrophon
+ExamRequiredEquipmentMicrophoneInternet: Mikrophon
 
 ExamCorrectors: Korrektoren
 ExamCorrectorsTip: Hier eingetragene Korrektoren können zwischen Beginn der Prüfung und "Bewertung abgeschlossen ab" Ergebnisse für alle Teilprüfungen und alle Teilnehmer im System hinterlegen.
@@ -1889,6 +1933,10 @@ ExamFinishedMustBeAfterStart: "Ergebnisse sichtbar ab" muss nach Beginn liegen
 ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Ergebnisse sichtbar ab" liegen
 ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Beginn liegen
 ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen
+ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Beginn" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
+ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen.
+ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann.
+ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten
 
 ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen
 ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen
@@ -2208,6 +2256,13 @@ ApplicationRatingCommentVisibleTip: Feedback an den Bewerbers
 ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursverwalter
 ApplicationRatingSection: Bewertung
 ApplicationRatingSectionSelfTip: Sie verfügen über hinreichende Authorisierung um sowohl die Bewerbung als auch ihre Bewertung zu editieren.
+AllocationNotificationNewCourse: Benachrichtigung bei neuen Kursen
+AllocationNotificationNewCourseTip: Wollen Sie per E-Mail benachrichtigt werden, wenn für diese Zentralanmeldung ein neuer Kurs eingetragen wird? Dies überschreibt die systemweite Einstellung in "Anpassen".
+AllocationNotificationNewCourseSuccessForceOn: Sie werden benachrichtigt, wenn ein neuer Kurs eingetragen wird
+AllocationNotificationNewCourseSuccessForceOff: Sie werden nicht benachrichtigt, wenn ein neuer Kurs eingetragen wird
+AllocationNotificationNewCourseCurrentlyOff: Aktuell würden Sie keine Benachrichtigung erhalten.
+AllocationNotificationNewCourseCurrentlyOn: Aktuell würden Sie benachrichtigt werden.
+AllocationNotificationLoginFirst: Um Ihre Benachrichtigungseinstellungen zu ändern, loggen Sie sich bitte zunächst ein.
 
 AllocationSchoolShort: Institut
 Allocation: Zentralanmeldung
@@ -2238,6 +2293,13 @@ SchoolName: Name
 SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
 SchoolLdapOrganisationsTip: Beim Login via LDAP werden dem Nutzer alle Institute zugeordnet deren assoziierte LDAP-Fragmente im Eintrag des Nutzer gefunden werden
 SchoolLdapOrganisationMissing: LDAP-Fragment wird benötigt
+SchoolExamMinimumRegisterBeforeStart: Minimale Tage zwischen Anmeldebeginn und Termin für Prüfungen
+SchoolExamMinimumRegisterBeforeStartTip: Wenn angegeben werden Dozenten gezwungen Anmeldezeitraum und Prüfungstermin stets zusammen einzustellen.
+SchoolExamMinimumRegisterDuration: Minimale Anmeldedauer für Prüfungen
+SchoolExamMinimumRegisterDurationTip: Wenn angegeben werden Dozenten daran gehindert Anmeldefristen von weniger als der minimalen Dauer für ihre Prüfungen einzustellen.
+SchoolExamRequireModeForRegistration: Prüfungsmodus erforderlich für Anmeldung
+SchoolExamRequireModeForRegistrationTip: Sollen Dozenten gezwungen werden Prüfungsmodus und Anmeldefrist stets zusammen einzustellen?
+SchoolExamDiscouragedModes: Prüfungsmodi mit Warnung
 
 SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
 SchoolTitle ssh@SchoolId: Institut „#{ssh}“
@@ -2299,6 +2361,11 @@ MailAllocationUnratedApplicationsIntroMultiple n@Int: Es stehen noch Bewertungen
 MailAllocationUnratedApplications n@Int: Für die unten aufgeführten Kurse liegen Bewerbungen vor, die im Rahmen der #{pluralDE n "Zentralanmeldung" "Zentralanmeldungen"} an den jeweiligen Kurs gestellt wurden, die entweder noch nicht bewertet wurden oder die nach der Bewertung noch verändert wurden und deswegen neu bewertet werden müssen.
 MailAllocationUnratedApplicationsCount i@Natural: #{i} #{pluralDE i "Bewerbung" "Bewerbungen"}
 
+MailSubjectAllocationNewCourse allocation@AllocationName: Es wurde ein zusätzlicher Kurs zur Zentralanmeldung „#{allocation}” eingetragen
+MailAllocationNewCourseTip: Es wurde der folgende Kurs zur Zentralanmeldung eingetragen:
+MailAllocationNewCourseEditApplicationsHere: Sie können Ihre Bewerbung(en) hier anpassen:
+MailAllocationNewCourseApplyHere: Sie können sich hier bewerben:
+
 ExamOfficeSubscribedUsers: Benutzer
 ExamOfficeSubscribedUsersTip: Sie können mehrere Matrikelnummern mit Komma separieren
 
@@ -2807,3 +2874,6 @@ WorkflowDefinitionConcreteInstanceCount num@Int64: #{num} Instanzen
 WorkflowDefinitionConcreteWorkflowCount num@Int64: #{num} Workflows
 WorkflowDefinitionDeleteQuestion: Wollen Sie die unten aufgeführte Workflow-Definition wirklich löschen?
 WorkflowDefinitionDeleted: Workflow-Definition gelöscht
+
+ChangelogItemFeature: Feature
+ChangelogItemBugfix: Bugfix

messages/uniworx/en-eu.msg

@@ -787,6 +787,15 @@ FormBehaviour: Behaviour
 FormCosmetics: Interface
 FormPersonalAppearance: Public data
 FormFieldRequiredTip: Required fields
+FormAllocationNotifications: Notifications for new central allocation courses
+FormAllocationNotificationsTip: Do you want to receive a notification if a new course is added to the central allocation? “Yes” and “No” override the system wide setting under “Notifications”
+
+AllocNotifyNewCourseDefault: System wide setting
+AllocNotifyNewCourseForceOff: No
+AllocNotifyNewCourseForceOn: Yes
+
+BtnNotifyNewCourseForceOn: Notify me
+BtnNotifyNewCourseForceOff: Do not notify me
 
 PersonalInfoExamAchievementsWip: The feature to display your exam achievements has not yet been implemented.
 PersonalInfoOwnTutorialsWip: The feature to display tutorials you have been assigned to as tutor has not yet been implemented.
@@ -1134,6 +1143,8 @@ NotificationTriggerCourseRegistered: A course administrator has enrolled me in a
 NotificationTriggerSubmissionUserCreated: I was added to an exercise sheet submission
 NotificationTriggerSubmissionEdited: One of my exercise sheet submissions was changed
 NotificationTriggerSubmissionUserDeleted: I was removed from one of my exercise sheet submissions
+NotificationTriggerAllocationNewCourse: A new course was added to a central allocation for which I have registered my participation
+NotificationTriggerAllocationNewCourseTip: Can be overridden per central allocation
 
 NotificationTriggerKindAll: For all users
 NotificationTriggerKindCourseParticipant: For course participants
@@ -1836,6 +1847,39 @@ ExamFormOccurrences: Occurrences/rooms
 ExamFormAutomaticFunctions: Automatic functions
 ExamFormCorrection: Correction
 ExamFormParts: Exam parts
+ExamFormMode: Exam design
+
+ExamModeFormNone: Not specified
+ExamModeFormCustom: Custom
+ExamModeFormAids: Permitted exam aids
+ExamModeFormOnline: Online/Offline
+ExamModeFormSynchronicity: Synchronous/Asynchronous
+ExamModeFormRequiredEquipment: Required equipment
+ExamModeFormRequiredEquipmentIdentificationTip: There will always be a note informing participants that they will need photo identification.
+
+ExamShowAids: Permitted exam aids
+ExamShowOnline: Online/Offline
+ExamShowSynchronicity: Synchronous/Asynchronous
+ExamShowRequiredEquipment: Required equipment
+ExamShowRequiredEquipmentNoneSet: Not specified
+ExamShowIdentificationRequired: Exam participants need to be able to identify themselves. Therefor please ensure that you have official photo identification („Personalausweis“, passport, residence permit) and your student identification at hand during the exam.
+
+ExamOpenBook: Open book
+ExamClosedBook: Closed book
+
+ExamOnline: Online
+ExamOffline: Offline
+
+ExamSynchronous: Synchronous
+ExamAsynchronous: Asynchronous
+
+ExamRequiredEquipmentNone: Nothing
+ExamRequiredEquipmentPen: Pen
+ExamRequiredEquipmentPaperPen: Pen & paper
+ExamRequiredEquipmentCalculatorPen: Pen & calculator
+ExamRequiredEquipmentCalculatorPaperPen: Pen, paper & calculator
+ExamRequiredEquipmentWebcamMicrophoneInternet: Webcam & microphone
+ExamRequiredEquipmentMicrophoneInternet: Microphone
 
 ExamCorrectors: Correctors
 ExamCorrectorsTip: Correctors configured here may, after the start of the exam and until "Results visible from", enter exam part results for all exam parts and participants.
@@ -1888,6 +1932,10 @@ ExamFinishedMustBeAfterStart: "Results visible from" must be after "start"
 ExamClosedMustBeAfterFinished: "Exam achievements registered" must be after "results visible from"
 ExamClosedMustBeAfterStart: "Exam achievements registered" must be after "start"
 ExamClosedMustBeAfterEnd: "Exam achievements registered" must be after "end"
+ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Start".
+ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to".
+ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set.
+ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged
 
 ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start
 ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start
@@ -2207,6 +2255,13 @@ ApplicationRatingCommentVisibleTip: Feedback for the applicant
 ApplicationRatingCommentInvisibleTip: Currently only a note for course administrators
 ApplicationRatingSection: Grading
 ApplicationRatingSectionSelfTip: You are authorised to edit the application as well as it's grading.
+AllocationNotificationNewCourse: Notifications for new courses
+AllocationNotificationNewCourseTip: Do you want to be notified if a new course is added to this central allocation? This overrides the system wide setting under “Settings”.
+AllocationNotificationNewCourseSuccessForceOn: You will be notified if a new course is added
+AllocationNotificationNewCourseSuccessForceOff: You will not be notified if a new course is added
+AllocationNotificationNewCourseCurrentlyOff: Currently you would not receive a notification.
+AllocationNotificationNewCourseCurrentlyOn: Currently you would be notified.
+AllocationNotificationLoginFirst: To change your notification settings, please log in first.
 
 AllocationSchoolShort: Department
 Allocation: Central allocation
@@ -2238,6 +2293,13 @@ SchoolName: Name
 SchoolLdapOrganisations: Associated LDAP fragments
 SchoolLdapOrganisationsTip: When logging in users are associated with any departments whose associated LDAP fragments are found in the users LDAP entry
 SchoolLdapOrganisationMissing: LDAP-fragment is required
+SchoolExamMinimumRegisterBeforeStart: Minimum number of days between start of registration period and start of exams
+SchoolExamMinimumRegisterBeforeStartTip: If specified course administrators will be forced to specify the start of the registration period and the start of the exam at the same time.
+SchoolExamMinimumRegisterDuration: Minimum duration of registration period for exams
+SchoolExamMinimumRegisterDurationTip: If specified course administrators will be prevented from setting a registration period of less than the specified number of days.
+SchoolExamRequireModeForRegistration: Exam design required for registration
+SchoolExamRequireModeForRegistrationTip: Should course administrators be forced to fully specify their exam design when setting a registration period?
+SchoolExamDiscouragedModes: Exam designs to warn against
 
 SchoolUpdated ssh: Successfully edited #{ssh}
 SchoolTitle ssh: Department „#{ssh}“
@@ -2299,6 +2361,11 @@ MailAllocationUnratedApplicationsIntroMultiple n: There are unrated applications
 MailAllocationUnratedApplications n: For there courses listed below, there exist applications made in the context of #{pluralEN n "the central allocation" "one of the central allocations"} which have either not yet been rated or which have changed since they were rated.
 MailAllocationUnratedApplicationsCount i: #{i} #{pluralDE i "application" "applications"}
 
+MailSubjectAllocationNewCourse allocation: A new course was added to the central allocation “#{allocation}”
+MailAllocationNewCourseTip: The following course was added to the central allocation:
+MailAllocationNewCourseEditApplicationsHere: You can modify your application here:
+MailAllocationNewCourseApplyHere: You can apply here:
+
 ExamOfficeSubscribedUsers: Users
 ExamOfficeSubscribedUsersTip: You may specify multiple matriculations; comma-separated
 
@@ -2775,6 +2842,7 @@ CronMatchNone: Never
 
 SystemExamOffice: Exam office
 SystemFaculty: Faculty member
+
 WorkflowInstanceScopeKindGlobal: Global
 WorkflowInstanceScopeKindTerm: Per term
 WorkflowInstanceScopeKindSchool: Per school
@@ -2807,3 +2875,6 @@ WorkflowDefinitionConcreteInstanceCount num: #{num} instances
 WorkflowDefinitionConcreteWorkflowCount num: #{num} workflows
 WorkflowDefinitionDeleteQuestion: Do you really want to delete the workflow definition listed below?
 WorkflowDefinitionDeleted: Successfully deleted workflow definition
+
+ChangelogItemFeature: Feature
+ChangelogItemBugfix: Bugfix

models/allocations.model

@@ -50,3 +50,9 @@ AllocationDeregister -- self-inflicted user-deregistrations from an allocated co
     course              CourseId Maybe
     time                UTCTime
     reason              Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
+
+AllocationNotificationSetting
+    user                UserId
+    allocation          AllocationId
+    isOptOut            Bool
+    UniqueAllocationNotificationSetting user allocation

models/changelog.model

@@ -0,0 +1,4 @@
+ChangelogItemFirstSeen
+  item ChangelogItem
+  firstSeen Day
+  Primary item

models/exams.model

@@ -17,6 +17,7 @@ Exam
   publicStatistics Bool
   gradingMode ExamGradingMode
   description Html Maybe
+  examMode ExamMode
   UniqueExam course name
 ExamPart
   exam ExamId

models/schools.model

@@ -3,6 +3,10 @@
 School json
     name          (CI Text)
     shorthand     (CI Text)  -- SchoolKey :: SchoolShorthand -> SchoolId
+    examMinimumRegisterBeforeStart NominalDiffTime Maybe
+    examMinimumRegisterDuration    NominalDiffTime Maybe
+    examRequireModeForRegistration Bool default=false
+    examDiscouragedModes ExamModeDNF
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
     Primary shorthand        -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 20.4.1
+version: 20.5.0
 
 dependencies:
   - base
@@ -25,7 +25,7 @@ dependencies:
   - directory
   - warp
   - data-default
-  - aeson
+  - aeson >=1.5
   - conduit
   - monad-logger
   - fast-logger
@@ -159,6 +159,7 @@ other-extensions:
   - IncoherentInstances
   - OverloadedLists
   - UndecidableInstances
+  - ApplicativeDo
 
 default-extensions:
   - OverloadedStrings

routes

@@ -114,7 +114,7 @@
 
 /allocation/               AllocationListR     GET             !free
 /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
-  /                                              AShowR         GET             !free
+  /                                              AShowR         GET POST        !free
   /register                                      ARegisterR         POST        !time
   /course/#CryptoUUIDCourse/apply                AApplyR            POST        !timeANDallocation-registered
   /users                                         AUsersR        GET POST        !allocation-admin

src/Data/Time/Calendar/Instances.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.Time.Calendar.Instances
@@ -11,8 +10,13 @@ import Data.Time.Calendar
 
 import Data.Universe
 
+import Language.Haskell.TH.Syntax (Lift)
+import Type.Reflection
 
-deriving newtype instance Hashable Day
+
+deriving instance Lift Day
+instance Hashable Day where
+  hashWithSalt s (ModifiedJulianDay jDay) = s `hashWithSalt` hash (typeRep @Day) `hashWithSalt` jDay
 
 deriving instance Ord DayOfWeek
 instance Universe DayOfWeek where

src/Data/Universe/Instances/Reverse/WithIndex.hs

@@ -11,7 +11,7 @@ import Control.Lens.Indexed
 
 import Data.Universe.Instances.Reverse ()
 
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as Map
 
 
 instance Finite a => FoldableWithIndex a ((->) a) where

src/Data/Universe/TH.hs

@@ -14,7 +14,10 @@ import Data.Universe.Helpers (interleave)
 
 import Control.Monad (unless)
 
-import Data.List (elemIndex)
+import Data.List (elemIndex, nub)
+  
+import Control.Lens hiding (universe)
+import Data.Generics.Product.Types
 
 
 -- | Get type var bind name
@@ -52,26 +55,37 @@ finiteEnum tName = do
     |]
 
 deriveUniverse, deriveFinite :: Name -> DecsQ
-deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
+deriveUniverse tName = view _1 <$> deriveUniverse' [e|interleave|] [e|universe|] ([t|Universe|] `appT`) tName
-deriveFinite tName = fmap concat . sequence $
+deriveFinite tName = do
-  [ deriveUniverse' [e|concat|] [e|universeF|] tName
+  (decs, iCxt) <- deriveUniverse' [e|concat|] [e|universeF|] ([t|Finite|] `appT`) tName
-  , do
+  fmap concat . sequence $
-      DatatypeInfo{..} <- reifyDatatype tName
+    [ pure decs
-      [d|instance Finite $(foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars)|]
+    , do
-  ]
+        DatatypeInfo{..} <- reifyDatatype tName
+        pure <$> instanceD (pure iCxt) (appT [t|Finite|] . foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars) []
+    ]
 
-deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
+deriveUniverse' :: ExpQ -> ExpQ -> (TypeQ -> TypeQ) -> Name -> Q ([Dec], Cxt)
-deriveUniverse' interleaveExp universeExp tName = do
+deriveUniverse' interleaveExp universeExp mkCxt tName = do
   DatatypeInfo{..} <- reifyDatatype tName
 
-  let datatype = foldl appT (conT datatypeName) $ map (varT . getTVBName) datatypeVars
+  let consUniverse ConstructorInfo{..} = do
-      consUniverse ConstructorInfo{..} = do
         unless (null constructorVars) $
           fail "Constructors with variables no supported"
 
         foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
 
-  pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
+      typ = foldl (\t bndr -> t `appT` varT (getTVBName bndr)) (conT tName) datatypeVars
+      iCxt = map (mkCxt . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
+        where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map getTVBName datatypeVars
+              usesVar ConstructorInfo{..} n
+                | n `elem` map getTVBName constructorVars = False
+                | otherwise = any (elemOf types n) constructorFields
+              fieldTypes = nub $ concatMap constructorFields datatypeCons
+
+  iCxt' <- cxt iCxt
+
+  (, iCxt') . pure <$> instanceD (pure iCxt') [t|Universe $(typ)|]
     [ funD 'universe
       [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
       ]

src/Data/Void/Instances.hs

@@ -10,3 +10,6 @@ instance ToContent Void where
   toContent = absurd
 instance ToTypedContent Void where
   toTypedContent = absurd
+
+instance RenderMessage site Void where
+  renderMessage _ _ = absurd

src/Foundation/I18n.hs

@@ -47,10 +47,6 @@ import Data.Text.Lens (packed)
 import Data.List ((!!))
 
 
-appLanguages :: NonEmpty Lang
-appLanguages = "de-de-formal" :| ["en-eu"]
-
-
 pluralDE :: (Eq a, Num a)
             =>    a -- ^ Count
             -> Text -- ^ Singular
@@ -225,6 +221,11 @@ embedRenderMessage ''UniWorX ''Quoting ("Csv" <>)
 embedRenderMessage ''UniWorX ''FavouriteReason id
 embedRenderMessage ''UniWorX ''Sex id
 embedRenderMessage ''UniWorX ''ExamGradingMode id
+embedRenderMessage ''UniWorX ''ExamAidsPreset id
+embedRenderMessage ''UniWorX ''ExamOnlinePreset id
+embedRenderMessage ''UniWorX ''ExamSynchronicityPreset id
+embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
+embedRenderMessage ''UniWorX ''ChangelogItemKind id
 embedRenderMessage ''UniWorX ''WorkflowInstanceScope' $ ("WorkflowInstanceScopeKind" <>) . concat . drop 1 . splitCamel . fromMaybe (error "Expected WorkflowInstanceScope' to have '") . stripSuffix "'"
 
 embedRenderMessage ''UniWorX ''AuthenticationMode id

src/Foundation/SiteLayout.hs

@@ -446,7 +446,7 @@ applySystemMessages = liftHandler . maybeT_ . catchMPlus (Proxy @CryptoIDError)
       guard $ userSystemMessageShown <= Just systemMessageLastChanged
       guard $ userSystemMessageHidden <= Just systemMessageLastUnhide
 
-      (_, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
+      (_, smTrans) <- MaybeT $ getSystemMessage smId
       let
         (summary, content) = case smTrans of
           Nothing -> (systemMessageSummary, systemMessageContent)

src/Foundation/Yesod/Middleware.hs

@@ -7,7 +7,6 @@ import Import.NoFoundation hiding (yesodMiddleware)
 
 import Foundation.Type
 import Foundation.Routes
-import Foundation.I18n
 import Foundation.Authorization
 
 import Utils.Metrics

src/Handler/Allocation/Application.hs

@@ -19,10 +19,11 @@ import qualified Database.Esqueleto as E
 import qualified Data.Conduit.List as C
 
 
-data AllocationApplicationButton = BtnAllocationApply
+data AllocationApplicationButton
-                                 | BtnAllocationApplicationEdit
+  = BtnAllocationApply
-                                 | BtnAllocationApplicationRetract
+  | BtnAllocationApplicationEdit
-                                 | BtnAllocationApplicationRate
+  | BtnAllocationApplicationRetract
+  | BtnAllocationApplicationRate
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 instance Universe AllocationApplicationButton
 instance Finite AllocationApplicationButton
@@ -32,6 +33,11 @@ embedRenderMessage ''UniWorX ''AllocationApplicationButton id
 makePrisms ''AllocationApplicationButton
 
 instance Button UniWorX AllocationApplicationButton where
+  btnLabel BtnAllocationApply              = [whamlet|#{iconApply True} _{MsgBtnAllocationApply}|]
+  btnLabel BtnAllocationApplicationRetract = [whamlet|#{iconApply False} _{MsgBtnAllocationApplicationRetract}|]
+  btnLabel BtnAllocationApplicationEdit    = [whamlet|#{iconAllocationApplicationEdit} _{MsgBtnAllocationApplicationEdit}|]
+  btnLabel BtnAllocationApplicationRate = i18n BtnAllocationApplicationRate
+  
   btnClasses BtnAllocationApplicationRetract = [BCIsButton, BCDanger]
   btnClasses _ = [BCIsButton, BCPrimary]
 

src/Handler/Allocation/Register.hs

@@ -36,6 +36,19 @@ nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''AllocationRegisterButton id
 
 instance Button UniWorX AllocationRegisterButton where
+  btnLabel BtnAllocationRegister
+    = [whamlet|
+        $newline never
+        #{iconAllocationRegister} \
+        _{BtnAllocationRegister}
+      |]
+  btnLabel BtnAllocationRegistrationEdit
+    = [whamlet|
+        $newline never
+        #{iconAllocationRegistrationEdit} \
+        _{BtnAllocationRegistrationEdit}
+      |]
+  
   btnClasses _ = [BCIsButton, BCPrimary]
 
 postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void

src/Handler/Allocation/Show.hs

@@ -1,5 +1,5 @@
 module Handler.Allocation.Show
-  ( getAShowR
+  ( getAShowR, postAShowR
   ) where
 
 import Import
@@ -7,6 +7,7 @@ import Import
 import Utils.Course
 
 import Handler.Utils
+import Handler.Utils.Allocation (allocationNotifyNewCourses)
 
 import Handler.Allocation.Register
 import Handler.Allocation.Application
@@ -15,8 +16,34 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
 
-getAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
+data NotifyNewCourseButton
-getAShowR tid ssh ash = do
+  = BtnNotifyNewCourseForceOn
+  | BtnNotifyNewCourseForceOff
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+embedRenderMessage ''UniWorX ''NotifyNewCourseButton id
+nullaryPathPiece ''NotifyNewCourseButton $ camelToPathPiece' 2
+
+instance Button UniWorX NotifyNewCourseButton where
+  btnLabel BtnNotifyNewCourseForceOn
+    = [whamlet|
+        $newline never
+        #{iconNotification} \
+        _{BtnNotifyNewCourseForceOn}
+      |]
+  btnLabel BtnNotifyNewCourseForceOff
+    = [whamlet|
+        $newline never
+        #{iconNoNotification} \
+        _{BtnNotifyNewCourseForceOff}
+      |]
+
+  btnClasses _ = [BCIsButton]
+
+
+getAShowR, postAShowR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
+getAShowR = postAShowR
+postAShowR tid ssh ash = do
   muid <- maybeAuthId
   now  <- liftIO getCurrentTime
   ata  <- getSessionActiveAuthTags
@@ -33,7 +60,7 @@ getAShowR tid ssh ash = do
     resultCourseVisible :: Simple Field5 a (E.Value Bool) => Lens' a Bool
     resultCourseVisible = _5 . _Value
 
-  (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration) <- runDB $ do
+  (Entity aId Allocation{..}, School{..}, isAnyLecturer, courses, registration, wouldNotifyNewCourse) <- runDB $ do
     alloc@(Entity aId Allocation{allocationSchool}) <- getBy404 $ TermSchoolAllocationShort tid ssh ash
     school <- getJust allocationSchool
 
@@ -58,7 +85,9 @@ getAShowR tid ssh ash = do
 
     isAnyLecturer <- hasWriteAccessTo CourseNewR
 
-    return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration)
+    wouldNotifyNewCourse <- fmap (maybe False E.unValue . join) . for muid $ E.selectMaybe . pure . allocationNotifyNewCourses (E.val aId) . E.val
+
+    return (alloc, school, isAnyLecturer, nubOn (view $ resultCourse . _entityKey) courses, registration, wouldNotifyNewCourse)
 
   MsgRenderer mr <- getMsgRenderer
   let title = MsgAllocationTitle (mr . ShortTermIdentifier $ unTermKey allocationTerm) (unSchoolKey allocationSchool) allocationName
@@ -67,7 +96,7 @@ getAShowR tid ssh ash = do
   -- staffInformation <- anyM courses $ \(view $ resultCourse . _entityVal -> Course{..}) ->
   --   hasReadAccessTo $ CourseR courseTerm courseSchool courseShorthand CApplicationsR
   mayRegister <- hasWriteAccessTo $ AllocationR tid ssh ash ARegisterR
-  (registerForm, registerEnctype) <- generateFormPost . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
+  (registerForm, registerEnctype) <- generateFormPost . identifyForm FIDAllocationRegister . renderAForm FormStandard . allocationRegisterForm $ allocationUserToForm . entityVal <$> registration
   let
     registerBtn = bool BtnAllocationRegister BtnAllocationRegistrationEdit $ is _Just registration
     registerForm' = wrapForm' registerBtn registerForm FormSettings
@@ -79,6 +108,35 @@ getAShowR tid ssh ash = do
       , formAnchor = Nothing :: Maybe Text
       }
 
+  ((notificationResult, notificationForm), notificationEnctype) <- runFormPost . identifyForm FIDAllocationNotification . buttonForm' $ if
+    | wouldNotifyNewCourse
+      -> [BtnNotifyNewCourseForceOff]
+    | otherwise
+      -> [BtnNotifyNewCourseForceOn]
+  let
+    allocationNotificationIdent = "allocation-notification" :: Text
+    notificationForm' = wrapForm notificationForm FormSettings
+      { formMethod = POST
+      , formAction = Just . SomeRoute $ AllocationR tid ssh ash AShowR
+      , formEncoding = notificationEnctype
+      , formAttrs = []
+      , formSubmit = FormNoSubmit
+      , formAnchor = Just allocationNotificationIdent
+      }
+
+  whenIsJust muid $ \uid -> formResult notificationResult $ \notificationBtn -> do
+    let allocationNotificationSettingIsOptOut = case notificationBtn of
+          BtnNotifyNewCourseForceOn  -> False
+          BtnNotifyNewCourseForceOff -> True
+    runDB . void $ upsertBy (UniqueAllocationNotificationSetting uid aId) AllocationNotificationSetting
+      { allocationNotificationSettingUser = uid
+      , allocationNotificationSettingAllocation = aId
+      , allocationNotificationSettingIsOptOut
+      }
+      [ AllocationNotificationSettingIsOptOut =. allocationNotificationSettingIsOptOut ]
+    addMessageI Success $ bool MsgAllocationNotificationNewCourseSuccessForceOn MsgAllocationNotificationNewCourseSuccessForceOff allocationNotificationSettingIsOptOut
+    redirect $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: allocationNotificationIdent
+
   siteLayoutMsg title $ do
     setTitleI shortTitle
 

src/Handler/Course/Edit.hs

@@ -563,18 +563,18 @@ courseEditHandler miButtonAction mbCourseForm = do
         , formEncoding = formEnctype
         }
 
-upsertAllocationCourse :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
+upsertAllocationCourse :: CourseId -> Maybe AllocationCourseForm -> YesodJobDB UniWorX ()
 upsertAllocationCourse cid cfAllocation = do
   now <- liftIO getCurrentTime
   Course{} <- getJust cid
   prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
-  prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
+  prevAllocation <- fmap join . traverse getEntity $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
-  userAdmin <- fromMaybe False <$> for prevAllocation (\Allocation{..} -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
+  userAdmin <- fromMaybe False <$> for prevAllocation (\(Entity _ Allocation{..}) -> hasWriteAccessTo $ SchoolR allocationSchool SchoolEditR)
 
   doEdit <- if
     | userAdmin
       -> return True
-    | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
+    | Just (Entity _ Allocation{allocationStaffRegisterTo}) <- prevAllocation
     , NTop allocationStaffRegisterTo <= NTop (Just now)
       -> let anyChanges
                | Just AllocationCourseForm{..} <- cfAllocation
@@ -590,7 +590,7 @@ upsertAllocationCourse cid cfAllocation = do
 
   when doEdit $
     case cfAllocation of
-      Just AllocationCourseForm{..} ->
+      Just AllocationCourseForm{..} -> do
         void $ upsert AllocationCourse
           { allocationCourseAllocation  =  acfAllocation
           , allocationCourseCourse      =  cid
@@ -600,6 +600,9 @@ upsertAllocationCourse cid cfAllocation = do
           , AllocationCourseCourse      =. cid
           , AllocationCourseMinCapacity =. acfMinCapacity
           ]
+
+        when (Just acfAllocation /= fmap entityKey prevAllocation) $
+          queueDBJob . JobQueueNotification $ NotificationAllocationNewCourse acfAllocation cid
       Nothing
         | Just (Entity prevId _) <- prevAllocationCourse
           -> delete prevId

src/Handler/Exam/Edit.hs

@@ -25,7 +25,7 @@ postEEditR tid ssh csh examn = do
 
     return (cid, exam, template)
 
-  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
+  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template
 
   formResult editExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do
@@ -48,6 +48,7 @@ postEEditR tid ssh csh examn = do
         , examPublicStatistics = efPublicStatistics
         , examGradingMode      = efGradingMode
         , examDescription      = efDescription
+        , examExamMode         = efExamMode
         }
 
       when (is _Nothing insertRes) $ do

src/Handler/Exam/Form.hs

@@ -12,12 +12,14 @@ import Handler.Exam.CorrectorInvite ()
 
 import Handler.Utils
 import Handler.Utils.Invitations
+import Handler.Utils.Exam (evalExamModeDNF)
 
 import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
 
 import qualified Control.Monad.State.Class as State
 import Text.Blaze.Html.Renderer.String (renderHtml)
@@ -40,6 +42,7 @@ data ExamForm = ExamForm
   , efGradingRule :: Maybe ExamGradingRule
   , efBonusRule :: Maybe ExamBonusRule
   , efOccurrenceRule :: ExamOccurrenceRule
+  , efExamMode :: ExamMode
   , efCorrectors :: Set (Either UserEmail UserId)
   , efExamParts :: Set ExamPartForm
   }
@@ -117,6 +120,8 @@ examForm template html = do
     <*> optionalActionA (examGradingRuleForm $ efGradingRule =<< template) (fslI MsgExamAutomaticGrading & setTooltip MsgExamAutomaticGradingTip) (is _Just . efGradingRule <$> template)
     <*> optionalActionA (examBonusRuleForm $ efBonusRule =<< template) (fslI MsgExamBonus) (is _Just . efBonusRule <$> template)
     <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
+    <*  aformSection MsgExamFormMode
+    <*> examModeForm (efExamMode <$> template)
     <*  aformSection MsgExamFormCorrection
     <*> examCorrectorsForm (efCorrectors <$> template)
     <*  aformSection MsgExamFormParts
@@ -302,6 +307,7 @@ examFormTemplate (Entity eId Exam{..}) = do
           Entity _ ExamCorrector{..} <- correctors
           return examCorrectorUser
       ]
+    , efExamMode         = examExamMode
     }
 
 examTemplate :: CourseId -> DB (Maybe ExamForm)
@@ -347,11 +353,12 @@ examTemplate cid = runMaybeT $ do
     , efOccurrences      = Set.empty
     , efExamParts        = Set.empty
     , efCorrectors       = Set.empty
+    , efExamMode         = examExamMode oldExam
     }
 
 
-validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
+validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m ()
-validateExam = do
+validateExam cId oldExam = do
   ExamForm{..} <- State.get
 
   guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
@@ -377,3 +384,50 @@ validateExam = do
       ]
 
     guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
+
+  mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
+    E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+    E.where_ $ course E.^. CourseId E.==. E.val cId
+    return school
+
+  whenIsJust mSchool $ \(Entity _ School{..}) -> do
+    whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
+      let doValidation
+            | Just Exam{..} <- oldExam
+            , not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
+            = warnValidation
+            | otherwise
+            = guardValidation
+      doValidation (MsgExamRegistrationMustFollowSchoolSeparationFromStart . ceiling $ minSep / nominalDay)
+        . fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
+    whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
+      let doValidation
+            | Just Exam{..} <- oldExam
+            , not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
+            = warnValidation
+            | otherwise
+            = guardValidation
+      doValidation (MsgExamRegistrationMustFollowSchoolDuration . ceiling $ minDur / nominalDay)
+        . fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
+    when schoolExamRequireModeForRegistration $ do
+      let doValidation
+            | Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam
+            , or [ is _Nothing examAids
+                 , is _Nothing examOnline
+                 , is _Nothing examSynchronicity
+                 , is _Nothing examRequiredEquipment
+                 ]
+            , is _Just examRegisterFrom
+            = warnValidation
+            | otherwise
+            = guardValidation
+      let ExamMode{..} = efExamMode
+      doValidation MsgExamModeRequiredForRegistration
+        $ is _Nothing efRegisterFrom
+       || and [ is _Just examAids
+              , is _Just examOnline
+              , is _Just examSynchronicity
+              , is _Just examRequiredEquipment
+              ]
+
+    warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode

src/Handler/Exam/New.hs

@@ -24,7 +24,7 @@ postCExamNewR tid ssh csh = do
     template <- examTemplate cid
     return (cid, template)
 
-  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
+  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
 
   formResult newExamResult $ \ExamForm{..} -> do
     insertRes <- runDBJobs $ do
@@ -49,6 +49,7 @@ postCExamNewR tid ssh csh = do
         , examGradingMode                  = efGradingMode
         , examPublicStatistics             = efPublicStatistics
         , examDescription                  = efDescription
+        , examExamMode                     = efExamMode
         }
       whenIsJust insertRes $ \examid -> do
         insertMany_

src/Handler/Exam/Show.hs

@@ -26,8 +26,9 @@ getEShowR tid ssh csh examn = do
   cTime <- liftIO getCurrentTime
   mUid <- maybeAuthId
 
-  (Entity eId Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
+  (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do
     exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
+    school <- getJust examCourse >>= belongsToJust courseSchool
 
     let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
 
@@ -82,7 +83,7 @@ getEShowR tid ssh csh examn = do
 
     lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
 
-    return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
+    return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown)
 
   let occurrenceNamesShown = lecturerInfoShown
       partNumbersShown = lecturerInfoShown
@@ -174,6 +175,11 @@ getEShowR tid ssh csh examn = do
 
   let heading = prependCourseTitle tid ssh csh $ CI.original examName
 
+  notificationDiscouragedExamMode <- runMaybeT $ do
+    guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode
+    guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR
+    return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged
+      
   siteLayoutMsg heading $ do
     setTitleI heading
     let
@@ -190,4 +196,6 @@ getEShowR tid ssh csh examn = do
 
       occurrenceMapping :: ExamOccurrenceName -> Maybe Widget
       occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (examExamOccurrenceMapping >>= Map.lookup occName . examOccurrenceMappingMapping)
+
+      notificationPersonalIdentification = notification NotificationBroad =<< messageIconI Info IconPersonalIdentification MsgExamShowIdentificationRequired
     $(widgetFile "exam-show")

src/Handler/Info.hs

@@ -5,7 +5,9 @@ import Handler.Utils
 import Handler.Info.TH
 
 import qualified Data.Map as Map
+import Data.Map ((!))
 import qualified Data.CaseInsensitive as CI
+import qualified Data.Set as Set
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
@@ -34,17 +36,26 @@ getLegalR =
 
 -- | Allgemeine Informationen
 getInfoR :: Handler Html
-getInfoR = -- do
+getInfoR = do
+  changelogEntries' <- runDB $ selectList [] []
+  let changelogEntries = Map.fromListWith Set.union
+        [ (Down changelogItemFirstSeenFirstSeen, Set.singleton changelogItemFirstSeenItem)
+        | Entity _ ChangelogItemFirstSeen{..} <- changelogEntries'
+        ]
+  
   siteLayoutMsg MsgInfoHeading $ do
     setTitleI MsgInfoHeading
     let features       = $(i18nWidgetFile "featureList")
-        changeLog      = $(i18nWidgetFile "changelog")
+        changeLog      = $(widgetFile "changelog")
         knownBugs      = $(i18nWidgetFile "knownBugs")
         implementation = $(i18nWidgetFile "implementation")
         gitInfo :: Text
         gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"
     $(widgetFile "versionHistory")
 
+  where
+    changelogItems = $(i18nWidgetFiles "changelog")
+
 
 getInfoLecturerR :: Handler Html
 getInfoLecturerR =
@@ -67,9 +78,9 @@ getInfoLecturerR =
 
     -- new feature with given introduction date
     newFeat :: Integer -> Int -> Int -> WidgetFor UniWorX ()
-    newFeat year month day = do
+    newFeat y m d = do
       currentTime <- liftIO getCurrentTime
-      let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian year month day) 0
+      let expiryTime = UTCTime (addGregorianMonthsRollOver 1 $ fromGregorian y m d) 0
       if currentTime > expiryTime
         then mempty
         else toWidget [whamlet| ^{iconTooltip tooltipNew (Just IconNew) False} |]
@@ -90,7 +101,7 @@ getGlossaryR =
     msgMap = $(glossaryTerms "glossary")
 
 
-mkFaqItems "faq"
+mkI18nWidgetEnum "FAQ" "faq"
 mkMessageFor "UniWorX" "FAQItem" "messages/faq" "de-de-formal"
 
 faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX

src/Handler/Info/TH.hs

@@ -1,10 +1,8 @@
 module Handler.Info.TH
   ( glossaryTerms
-  , mkFaqItems
   ) where
 
 import Import
-import Handler.Utils.I18n
 
 import Language.Haskell.TH
 
@@ -22,52 +20,3 @@ glossaryTerms basename = do
   where
     unPathPiece :: Text -> String
     unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
-
-mkFaqItems :: FilePath -> DecsQ
-mkFaqItems basename = do
-  itemsAvailable <- i18nWidgetFilesAvailable' basename
-  let items = Map.mapWithKey (\k _ -> "FAQ" <> unPathPiece k) itemsAvailable
-  sequence
-    [ dataD (cxt []) dataName [] Nothing
-        [ normalC (mkName conName) []
-        | (_, conName) <- Map.toAscList items
-        ]
-        [ derivClause (Just StockStrategy)
-            [ conT ''Eq
-            , conT ''Ord
-            , conT ''Read
-            , conT ''Show
-            , conT ''Enum
-            , conT ''Bounded
-            , conT ''Generic
-            , conT ''Typeable
-            ]
-        , derivClause (Just AnyclassStrategy)
-            [ conT ''Universe
-            , conT ''Finite
-            ]
-        ]
-    , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
-      [ funD 'toPathPiece
-        [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
-        | (int, con) <- Map.toList items
-        ]
-      , funD 'fromPathPiece
-        [ clause [varP $ mkName "t"]
-          ( guardedB
-            [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
-            | (int, con) <- Map.toList items
-            ]) []
-        , clause [wildP] (normalB [e|Nothing|]) []
-        ]
-      ]
-    , sigD (mkName "faqItemMap") [t|Map Text $(conT dataName)|]
-    , funD (mkName "faqItemMap")
-        [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
-        ]
-    ]
-  where
-    unPathPiece :: Text -> String
-    unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
-
-    dataName = mkName "FAQItem"

src/Handler/News.hs

@@ -69,7 +69,7 @@ newsSystemMessages = do
   (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
        transPipe lift (selectKeys [] [])
     .| C.filterM (hasReadAccessTo . MessageR <=< encrypt)
-    .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage appLanguages smId)
+    .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
     .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
     .| C.mapMaybeM checkHidden
     .| C.iterM (\(smId, _, _, _) -> tellShown smId)

src/Handler/Profile.hs

@@ -45,6 +45,7 @@ data SettingsForm = SettingsForm
       , stgShowSex              :: Bool
       , stgSchools              :: Set SchoolId
       , stgNotificationSettings :: NotificationSettings
+      , stgAllocationNotificationSettings :: Map AllocationId (Maybe Bool)
       }
 makeLenses_ ''SettingsForm
 
@@ -79,6 +80,15 @@ instance RenderMessage UniWorX NotificationTriggerKind where
     where
       mr = renderMessage f ls
 
+data AllocationNotificationState
+  = AllocNotifyNewCourseDefault
+  | AllocNotifyNewCourseForceOff
+  | AllocNotifyNewCourseForceOn
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+embedRenderMessage ''UniWorX ''AllocationNotificationState id
+nullaryPathPiece ''AllocationNotificationState $ camelToPathPiece' 2
+
 
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
@@ -108,6 +118,7 @@ makeSettingForm template html = do
         <*  aformSection MsgFormNotifications
         <*> schoolsForm (stgSchools <$> template)
         <*> notificationForm (stgNotificationSettings <$> template)
+        <*> allocationNotificationForm (stgAllocationNotificationSettings <$> template)
     return (result, widget) -- no validation required here
   where
     themeList = [Option (toMessage t) t (toPathPiece t) | t <- universeF]
@@ -196,13 +207,17 @@ notificationForm template = wFormToAForm $ do
             & fmap (!)
 
   let
+    ntfs nt = fslI nt & case nt of
+      NTAllocationNewCourse -> setTooltip MsgNotificationTriggerAllocationNewCourseTip
+      _other -> id
+    
     nsForm nt
       | maybe False ntHidden $ ntSection nt
       = pure $ notificationAllowed def nt
       | nt `elem` forcedTriggers
-      = aforced checkBoxField (fslI nt) (notificationAllowed def nt)
+      = aforced checkBoxField (ntfs nt) (notificationAllowed def nt)
       | otherwise
-      = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
+      = apopt checkBoxField (ntfs nt) (flip notificationAllowed nt <$> template)
 
     ntSection = \case
       NTSubmissionRatedGraded          -> Just NTKCourseParticipant
@@ -229,6 +244,7 @@ notificationForm template = wFormToAForm $ do
       NTAllocationOutdatedRatings      -> Just NTKAllocationStaff
       NTAllocationUnratedApplications  -> Just NTKAllocationStaff
       NTAllocationResults              -> Just NTKAllocationParticipant
+      NTAllocationNewCourse            -> Just NTKAllocationParticipant
       NTExamOfficeExamResults          -> Just $ NTKFunctionary SchoolExamOffice
       NTExamOfficeExamResultsChanged   -> Just $ NTKFunctionary SchoolExamOffice
       NTCourseRegistered               -> Just NTKAll
@@ -238,6 +254,62 @@ notificationForm template = wFormToAForm $ do
 
   aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
 
+getAllocationNotifications :: UserId -> DB (Map AllocationId (Maybe Bool))
+getAllocationNotifications uid
+  = fmap (fmap (fmap getAny) . unMergeMap) . getAp $ foldMap (Ap . fmap (MergeMap . fmap (fmap Any)))
+      [ getBySettings
+      , getByApplications
+      , getByAllocationUser
+      ]
+  where
+    getBySettings = toMap <$> selectList [ AllocationNotificationSettingUser ==. uid ] []
+      where toMap settings = Map.fromList [ ( allocationNotificationSettingAllocation
+                                            , Just $ not allocationNotificationSettingIsOptOut
+                                            )
+                                          | Entity _ AllocationNotificationSetting{..} <- settings
+                                          ]
+    getByApplications = toMap <$> selectList [ CourseApplicationAllocation !=. Nothing, CourseApplicationUser ==. uid ] []
+      where toMap applications = Map.fromList [ (alloc, Nothing)
+                                              | Entity _ CourseApplication{..} <- applications
+                                              , alloc <- hoistMaybe courseApplicationAllocation
+                                              ]
+    getByAllocationUser = toMap <$> selectList [ AllocationUserUser ==. uid ] []
+      where toMap allocsUser = Map.fromList [ (allocationUserAllocation, Nothing)
+                                            | Entity _ AllocationUser{..} <- allocsUser
+                                            ]
+
+setAllocationNotifications :: forall m. MonadIO m => UserId -> Map AllocationId (Maybe Bool) -> SqlPersistT m ()
+setAllocationNotifications allocationNotificationSettingUser allocs = do
+  deleteWhere [ AllocationNotificationSettingUser ==. allocationNotificationSettingUser ]
+  void . insertMany $ do
+    (allocationNotificationSettingAllocation, settingSt) <- Map.toList allocs
+    allocationNotificationSettingIsOptOut <- not <$> hoistMaybe settingSt
+    return AllocationNotificationSetting{..}
+  
+allocationNotificationForm :: Maybe (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
+allocationNotificationForm = maybe (pure mempty) allocationNotificationForm' . (fromNullable =<<)
+  where
+    allocationNotificationForm' :: NonNull (Map AllocationId (Maybe Bool)) -> AForm Handler (Map AllocationId (Maybe Bool))
+    allocationNotificationForm' (toNullable -> allocs) = funcForm' . flip imap allocs $ \allocId mPrev -> wFormToAForm $ do
+      let _AllocNotify :: Iso' (Maybe Bool) AllocationNotificationState
+          _AllocNotify = iso toNotify fromNotify
+            where fromNotify = \case
+                    AllocNotifyNewCourseDefault  -> Nothing
+                    AllocNotifyNewCourseForceOn  -> Just True
+                    AllocNotifyNewCourseForceOff -> Just False
+                  toNotify = \case
+                    Nothing    -> AllocNotifyNewCourseDefault
+                    Just True  -> AllocNotifyNewCourseForceOn
+                    Just False -> AllocNotifyNewCourseForceOff
+
+      Allocation{..} <- liftHandler . runDB $ getJust allocId
+      MsgRenderer mr <- getMsgRenderer
+      let allocDesc = [st|#{mr (ShortTermIdentifier $ unTermKey allocationTerm)}, #{unSchoolKey allocationSchool}, #{allocationName}|]
+      cID <- encrypt allocId :: _ CryptoUUIDAllocation
+
+      fmap (review _AllocNotify) <$> wpopt (radioGroupField Nothing optionsFinite) (fsl allocDesc & addName [st|alloc-notify__#{toPathPiece cID}|]) (Just $ mPrev ^. _AllocNotify)
+      where funcForm' forms = funcForm forms (fslI MsgFormAllocationNotifications & setTooltip MsgFormAllocationNotificationsTip) False
+
 
 validateSettings :: User -> FormValidator SettingsForm Handler ()
 validateSettings User{..} = do
@@ -276,6 +348,7 @@ postProfileR = do
            E.&&. userSchool E.^. UserSchoolUser E.==. E.val uid
            E.&&. userSchool E.^. UserSchoolSchool E.==. school E.^. SchoolId
     return $ school E.^. SchoolId
+  allocs <- runDB $ getAllocationNotifications uid
   let settingsTemplate = Just SettingsForm
         { stgDisplayName          = userDisplayName
         , stgDisplayEmail         = userDisplayEmail
@@ -290,6 +363,7 @@ postProfileR = do
         , stgNotificationSettings = userNotificationSettings
         , stgWarningDays          = userWarningDays
         , stgShowSex              = userShowSex
+        , stgAllocationNotificationSettings = allocs
         }
   ((res,formWidget), formEnctype) <- runFormPost . validateForm (validateSettings user) . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
 
@@ -308,6 +382,7 @@ postProfileR = do
         , UserNotificationSettings =. stgNotificationSettings
         , UserShowSex              =. stgShowSex
         ] ++ [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ]
+      setAllocationNotifications uid stgAllocationNotificationSettings
       updateFavourites Nothing
       when (stgDisplayEmail /= userDisplayEmail) $ do
         queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail
@@ -777,9 +852,13 @@ getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
 getUserNotificationR = postUserNotificationR
 postUserNotificationR cID = do
   uid <- decrypt cID
-  User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
+  (User{userNotificationSettings, userDisplayName}, allocs) <- runDB $ (,)
+    <$> get404 uid
+    <*> getAllocationNotifications uid
 
-  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
+  ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard $ (,)
+    <$> notificationForm (Just userNotificationSettings)
+    <*> allocationNotificationForm (Just allocs)
   mBearer <- askBearer
   isModal <- hasCustomHeader HeaderIsModal
   let formWidget = wrapForm nsInnerWdgt def
@@ -788,8 +867,10 @@ postUserNotificationR cID = do
         , formAttrs = [ asyncSubmitAttr | isModal ]
         }
 
-  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \ns -> do
+  formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece bearer) | Just bearer <- pure mBearer ]) $ \(ns, ans) -> do
-    lift . runDB $ update uid [ UserNotificationSettings =. ns ]
+    lift . runDB $ do
+      update uid [ UserNotificationSettings =. ns ]
+      setAllocationNotifications uid ans
     tell . pure =<< messageI Success MsgNotificationSettingsUpdate
 
   siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do

src/Handler/School.hs

@@ -62,6 +62,10 @@ data SchoolForm = SchoolForm
   { sfShorthand :: CI Text
   , sfName :: CI Text
   , sfOrgUnits :: Set (CI Text)
+  , sfExamMinimumRegisterBeforeStart
+  , sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
+  , sfExamRequireModeForRegistration :: Bool
+  , sfExamDiscouragedModes :: ExamModeDNF
   }
 
 mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
@@ -69,6 +73,10 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
   <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
   <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
   <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
+  <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
+  <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
+  <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
+  <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
   where
     ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
     ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
@@ -82,6 +90,10 @@ schoolToForm ssh = do
     { sfShorthand = schoolShorthand
     , sfName = schoolName
     , sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
+    , sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart
+    , sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
+    , sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
+    , sfExamDiscouragedModes = schoolExamDiscouragedModes
     }
 
 
@@ -94,7 +106,13 @@ postSchoolEditR ssh = do
 
   formResult sfResult $ \SchoolForm{..} -> do
     runDB $ do
-      update ssh [ SchoolName =. sfName ]
+      update ssh
+        [ SchoolName =. sfName
+        , SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
+        , SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
+        , SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
+        , SchoolExamDiscouragedModes =. sfExamDiscouragedModes
+        ]
       forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
         void $ upsert SchoolLdap
           { schoolLdapSchool = Just ssh
@@ -131,6 +149,10 @@ postSchoolNewR = do
       didInsert <- is _Just <$> insertUnique School
         { schoolShorthand = sfShorthand
         , schoolName = sfName
+        , schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart
+        , schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
+        , schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
+        , schoolExamDiscouragedModes = sfExamDiscouragedModes
         }
       when didInsert $ do
         insert_ UserFunction

src/Handler/SystemMessage.hs

@@ -25,7 +25,7 @@ getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
 getMessageR = postMessageR
 postMessageR cID = do
   smId <- decrypt cID
-  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
+  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId
   let (summary, content) = case translation of
         Nothing -> (systemMessageSummary, systemMessageContent)
         Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
@@ -185,7 +185,7 @@ postMessageListR = do
             in cell . toWidget $ fromMaybe content summary
       ]
     dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
-      smT <- (>>= view _2) <$> getSystemMessage appLanguages smId
+      smT <- (>>= view _2) <$> getSystemMessage smId
       return DBRow
         { dbrOutput = (smE, smT)
         , ..

src/Handler/Utils/Allocation.hs

@@ -1,5 +1,5 @@
 module Handler.Utils.Allocation
-  ( allocationStarted
+  ( allocationStarted, allocationNotifyNewCourses
   , ordinalPriorities
   , sinkAllocationPriorities
   , MatchingLogRun(..)
@@ -70,6 +70,25 @@ allocationStarted allocId = fmap (E.unValue <=< listToMaybe) . E.select . E.from
   E.where_ $ allocationMatching E.^. AllocationMatchingAllocation E.==. E.val allocId
   return . E.min_ $ allocationMatching E.^. AllocationMatchingTime
 
+allocationNotifyNewCourses :: E.SqlExpr (E.Value AllocationId)
+                           -> E.SqlExpr (E.Value UserId)
+                           -> E.SqlExpr (E.Value Bool)
+allocationNotifyNewCourses allocId uid = ( hasOverride True E.||. hasApplication E.||. isParticipant )
+                                   E.&&.   E.not_ (hasOverride False)
+  where
+    hasOverride overrideVal = E.exists . E.from $ \allocationNotificationSetting ->
+      E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. uid
+           E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. allocId
+           E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut E.==. E.val (not overrideVal)
+
+    hasApplication = E.exists . E.from $ \application ->
+      E.where_ $ application E.^. CourseApplicationAllocation E.==. E.just allocId
+           E.&&. application E.^. CourseApplicationUser E.==. uid
+
+    isParticipant = E.exists . E.from $ \allocationUser ->
+      E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. allocId
+           E.&&. allocationUser E.^. AllocationUserUser E.==. uid
+
 
 ordinalPriorities :: Monad m => ConduitT UserMatriculation (Map UserMatriculation AllocationPriority) m ()
 ordinalPriorities = evalStateC 0 . C.mapM $ \matr -> singletonMap matr <$> (AllocationPriorityOrdinal <$> State.get <* State.modify' succ)

src/Handler/Utils/DateTime.hs

@@ -213,9 +213,9 @@ formatDiffDays t
 
 
 setYear :: Integer -> Day -> Day
-setYear year date = fromGregorian year month day
+setYear year date = fromGregorian year m d
   where
-    (_,month,day) = toGregorian date
+    (_,m,d) = toGregorian date
 
 addOneWeek :: UTCTime -> UTCTime
 addOneWeek = addWeeks 1
@@ -295,7 +295,7 @@ formatTimeRangeMail = formatTimeRange' formatTimeMail
 
 
 formatGregorianW :: Integer -> Int -> Int -> Widget
-formatGregorianW year month day = formatTimeW SelFormatDate $ fromGregorian year month day
+formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
 
 instance Csv.ToField ZonedTime where
   toField = Csv.toField . iso8601Show

src/Handler/Utils/Exam.hs

@@ -11,6 +11,8 @@ module Handler.Utils.Exam
   , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
   , examAutoOccurrence
   , deregisterExamUsersCount, deregisterExamUsers
+  , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
+  , evalExamModeDNF
   ) where
 
 import Import
@@ -50,6 +52,8 @@ import qualified Data.Char as Char
 
 import qualified Data.RFC5051 as RFC5051
 
+import Handler.Utils.I18n
+
 
 fetchExamAux :: ( SqlBackendCanRead backend
                 , E.SqlSelect b a
@@ -641,3 +645,38 @@ deregisterExamUsersCount eId uids = do
 
 deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
 deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids
+
+
+examAidsPresetWidget :: ExamAidsPreset -> Widget
+examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids")
+
+examOnlinePresetWidget :: ExamOnlinePreset -> Widget
+examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online")
+
+examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget
+examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity")
+
+examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget
+examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment")
+
+
+evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool
+evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
+  = dnfTerms
+  & map (Set.toList . toNullable) . Set.toList
+  & map ( maybe True (ofoldr1 (&&))
+        . fromNullable
+        . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl)
+        )
+  & maybe False (ofoldr1 (||)) . fromNullable
+  where
+    evalPred :: ExamModePredicate -> Bool
+    evalPred = \case
+      ExamModePredAids p
+        -> examAids              == Just (ExamAidsPreset p)
+      ExamModePredOnline p
+        -> examOnline            == Just (ExamOnlinePreset p)
+      ExamModePredSynchronicity p
+        -> examSynchronicity     == Just (ExamSynchronicityPreset p)
+      ExamModePredRequiredEquipment p
+        -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)

src/Handler/Utils/Form.hs

@@ -19,6 +19,8 @@ import Handler.Utils.I18n
 
 import Handler.Utils.Files
 
+import Handler.Utils.Exam
+
 import Import
 import Data.Char ( chr, ord, isDigit )
 import qualified Data.Char as Char
@@ -1379,35 +1381,28 @@ boolField mkNone = radioGroupField mkNone $ do
 
 
 
-sectionedFuncForm  :: forall k v m sec.
+sectionedFuncForm  :: forall f k v m sec.
-                      ( Finite k, Ord k
+                      ( TraversableWithIndex k f
                       , MonadHandler m
                       , HandlerSite m ~ UniWorX
                       , RenderMessage UniWorX sec
                       , Ord sec
                       )
-                   => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+                   => (k -> Maybe sec) -> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
 sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
   where
-    funcForm' :: AForm m (k -> v)
+    funcForm' :: AForm m (f v)
-    funcForm' = Set.fromList universeF
+    funcForm' = wFormToAForm $ do
-              & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
+      (res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form
-              & fmap (Map.fromSet mkForm)
+        -> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form
-              & fmap sequenceA
-              & Map.foldrWithKey accSections (pure Map.empty)
-              & fmap (!)
-    accSections mSection optsForm acc = wFormToAForm $ do
-      (res, fs) <- wFormFields $ aFormToWForm optsForm
-      if
-        | not $ null fs
-        , Just section <- mSection
-          -> wformSection section
-        | otherwise
-          -> return ()
-      lift $ tell fs
-      aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
 
-    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
+      iforM_ fs $ \mSection secfs -> unless (null secfs) $ do
+        traverse_ wformSection mSection
+        lift $ tell secfs
+
+      return $ sequenceA res
+
+    funcFieldView :: (FormResult (f v), Widget) -> MForm m (FormResult (f v), [FieldView UniWorX])
     funcFieldView (res, formView) = do
       mr <- getMessageRender
       fvId <- maybe newIdent return fsId
@@ -1419,16 +1414,15 @@ sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} is
             | otherwise = Nothing
           fvInput = $(widgetFile "widgets/fields/funcField")
       return (res, pure FieldView{..})
-    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
-funcForm :: forall k v m.
+funcForm :: forall f k v m.
-            ( Finite k, Ord k
+            ( TraversableWithIndex k f
             , MonadHandler m
             , HandlerSite m ~ UniWorX
             )
-         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+         => f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
-funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
+funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void)
 
 
 
@@ -1996,3 +1990,97 @@ courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (
 userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User))
              -> Handler (OptionList UserId)
 userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName
+
+
+data CustomPresetFormOption p
+  = CPFONone
+  | CPFOPreset p
+  | CPFOCustom
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveFinite ''CustomPresetFormOption
+derivePathPiece ''CustomPresetFormOption (camelToPathPiece' 1) "--"
+
+customPresetForm :: forall a custom preset msg.
+                    ( Finite preset, Ord preset, PathPiece preset
+                    , RenderMessage UniWorX msg
+                    )
+                 => Iso' a (Either custom preset)
+                 -> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
+                 -> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for custom option
+                 -> (preset -> (msg, Maybe Widget))
+                 -> (Maybe custom -> AForm Handler custom)
+                 -> FieldSettings UniWorX
+                 -> Maybe (Maybe a)
+                 -> AForm Handler (Maybe a)
+customPresetForm cpL noneOption customOption toOption customForm fs mPrev
+  = explainedMultiActionA actionMap options fs mPrev'
+  where
+    mPrev' = flip fmap mPrev $ preview (_Just . cpL) >>> \case
+      Nothing        -> CPFONone
+      Just (Left _)  -> CPFOCustom
+      Just (Right p) -> CPFOPreset p
+
+    options = explainOptionList options' $ hoistMaybe . optionToWidget
+      where options' = do
+              MsgRenderer mr <- getMsgRenderer
+              let olReadExternal t = do
+                    opt <- fromPathPiece t
+                    case opt of
+                      CPFONone -> opt <$ hoistMaybe noneOption
+                      CPFOCustom -> opt <$ hoistMaybe customOption
+                      CPFOPreset _ -> pure opt
+                  olOptions = do
+                    optionInternalValue <- universeF
+                    optionDisplay <- case optionInternalValue of
+                      CPFONone -> views _1 mr <$> hoistMaybe noneOption
+                      CPFOCustom -> views _1 mr <$> hoistMaybe customOption
+                      CPFOPreset p -> return . views _1 mr $ toOption p
+                    let optionExternalValue = toPathPiece optionInternalValue
+                    return Option{..}
+              return OptionList{..}
+            optionToWidget = \case
+              CPFONone -> noneOption ^? _Just . _2 . _Just
+              CPFOCustom -> customOption ^? _Just . _2 . _Just
+              CPFOPreset p -> toOption p ^. _2
+
+    actionMap :: Map (CustomPresetFormOption preset) (AForm Handler (Maybe a))
+    actionMap = Map.fromList $ do
+      opt <- universeF
+      return . (opt, ) $ case opt of
+        CPFONone -> pure Nothing
+        CPFOPreset p -> pure . Just $ cpL # Right p
+        CPFOCustom -> reviews cpL Just . Left <$> customForm (mPrev ^? _Just . _Just . cpL . _Left)
+
+examModeForm :: Maybe ExamMode -> AForm Handler ExamMode
+examModeForm mPrev = examMode
+  <$> customPresetForm examSynchronicityEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examSynchronicityPresetWidget) (apreq htmlField (fslI MsgExamModeFormSynchronicity)) (fslI MsgExamModeFormSynchronicity) (examSynchronicity <$> mPrev)
+  <*> customPresetForm examOnlineEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examOnlinePresetWidget) (apreq htmlField (fslI MsgExamModeFormOnline)) (fslI MsgExamModeFormOnline) (examOnline <$> mPrev)
+  <*> customPresetForm examAidsEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examAidsPresetWidget) (apreq htmlField (fslI MsgExamModeFormAids)) (fslI MsgExamModeFormAids) (examAids <$> mPrev)
+  <*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
+  where
+    examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
+    
+    examAidsEither :: Iso' ExamAids (Either Html ExamAidsPreset)
+    examAidsEither = iso examAidsToEither examAidsFromEither
+      where examAidsToEither (ExamAidsPreset p) = Right p
+            examAidsToEither (ExamAidsCustom c) = Left  c
+            examAidsFromEither (Right p) = ExamAidsPreset p
+            examAidsFromEither (Left  c) = ExamAidsCustom c
+    examOnlineEither :: Iso' ExamOnline (Either Html ExamOnlinePreset)
+    examOnlineEither = iso examOnlineToEither examOnlineFromEither
+      where examOnlineToEither (ExamOnlinePreset p) = Right p
+            examOnlineToEither (ExamOnlineCustom c) = Left  c
+            examOnlineFromEither (Right p) = ExamOnlinePreset p
+            examOnlineFromEither (Left  c) = ExamOnlineCustom c
+    examSynchronicityEither :: Iso' ExamSynchronicity (Either Html ExamSynchronicityPreset)
+    examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
+      where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
+            examSynchronicityToEither (ExamSynchronicityCustom c) = Left  c
+            examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
+            examSynchronicityFromEither (Left  c) = ExamSynchronicityCustom c
+    examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either Html ExamRequiredEquipmentPreset)
+    examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
+      where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
+            examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left  c
+            examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
+            examRequiredEquipmentFromEither (Left  c) = ExamRequiredEquipmentCustom c

src/Handler/Utils/I18n.hs

@@ -1,25 +1,23 @@
 module Handler.Utils.I18n
   ( i18nWidgetFile
-  , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable', i18nWidgetFiles
+  , i18nWidgetFiles
   , i18nMessage
+  , module Utils.I18n
   ) where
 
 import Import.NoFoundation
 import Foundation.Type
-import Foundation.I18n
+
+import Utils.I18n
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (qRunIO)
-import qualified Language.Haskell.TH.Syntax as TH
 
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
 
-import qualified Data.Set as Set
 import qualified Data.Map as Map
 
-import qualified Data.Text as Text
-
 import System.Directory (listDirectory)
 
 
@@ -52,20 +50,6 @@ i18nWidgetFile basename = do
                 ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
     ] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
 
-i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
-i18nWidgetFilesAvailable' basename = do
-  let i18nDirectory = "templates" </> "i18n" </> basename
-  availableFiles <- qRunIO $ listDirectory i18nDirectory
-  let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
-      fileKinds :: Map Text [Text]
-      fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
-      toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
-
-  iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
-
-i18nWidgetFilesAvailable :: FilePath -> Q Exp
-i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'
-
 i18nWidgetFiles :: FilePath -> Q Exp
 i18nWidgetFiles basename = do
   availableTranslations' <- i18nWidgetFilesAvailable' basename

src/Import/NoModel.hs

@@ -66,7 +66,7 @@ import Data.List              as Import (elemIndex)
 import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
 import Data.Semigroup         as Import (Min(..), Max(..))
-import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..))
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..), Alt(..), Dual(..), Ap(..))
 import Data.Binary            as Import (Binary)
 import Data.Binary.Instances  as Import ()
 

src/Jobs/Handler/QueueNotification.hs

@@ -14,6 +14,7 @@ import qualified Data.Set as Set
 
 import Handler.Utils.ExamOffice.Exam
 import Handler.Utils.ExamOffice.ExternalExam
+import Handler.Utils.Allocation (allocationNotifyNewCourses)
 
 import qualified Data.Conduit.Combinators as C
 
@@ -22,21 +23,24 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
 dispatchJobQueueNotification jNotification = JobHandlerAtomic $
   runConduit $ yield jNotification
             .| transPipe (hoist lift) determineNotificationCandidates
-            .| C.filterM (\(notification', Entity _ User{userNotificationSettings}) -> notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
+            .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings}) -> or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
-            .| C.map (\(notification', Entity uid _) -> JobSendNotification uid notification')
+            .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
             .| sinkDBJobs
 
 
-determineNotificationCandidates :: ConduitT Notification (Notification, Entity User) DB ()
+determineNotificationCandidates :: ConduitT Notification (Notification, Bool, Entity User) DB ()
 determineNotificationCandidates = awaitForever $ \notif -> do
-  let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Entity User) DB ()
+  let withNotif :: ConduitT () (Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
-      withNotif c = toProducer c .| C.map (notif, )
+      withNotif c = toProducer c .| C.map (notif, False, )
+
+      withNotifOverride :: ConduitT () (E.Value Bool, Entity User) DB () -> ConduitT Notification (Notification, Bool, Entity User) DB ()
+      withNotifOverride c = toProducer c .| C.map (\(E.Value override, user) -> (notif, override, user))
 
       -- | Assumes that conduit produces output sorted by `UserId`
       separateTargets :: Ord target
                       => (Set target -> Notification)
                       -> ConduitT () (Entity User, E.Value target) DB ()
-                      -> ConduitT Notification (Notification, Entity User) DB ()
+                      -> ConduitT Notification (Notification, Bool, Entity User) DB ()
       separateTargets mkNotif' c = toProducer c .| go Nothing Set.empty
         where go Nothing _ = do
                 next <- await
@@ -46,10 +50,10 @@ determineNotificationCandidates = awaitForever $ \notif -> do
               go (Just uent) ts = do
                 next <- await
                 case next of
-                  Nothing -> yield (mkNotif' ts, uent)
+                  Nothing -> yield (mkNotif' ts, False, uent)
                   Just next'@(uent', E.Value t)
                     | ((==) `on` entityKey) uent uent' -> go (Just uent) $ Set.insert t ts
-                    | otherwise -> yield (mkNotif' ts, uent) >> leftover next' >> go Nothing Set.empty
+                    | otherwise -> yield (mkNotif' ts, False, uent) >> leftover next' >> go Nothing Set.empty
                 
   case notif of
     NotificationSubmissionRated{..}
@@ -281,6 +285,21 @@ determineNotificationCandidates = awaitForever $ \notif -> do
       -> withNotif . yieldMMany $ getEntity nUser
     NotificationSubmissionUserDeleted{..}
       -> withNotif . yieldMMany $ getEntity nUser
+    NotificationAllocationNewCourse{..}
+      -> withNotifOverride . E.selectSource . E.from $ \user -> do
+           let hasOverride = E.exists . E.from $ \allocationNotificationSetting ->
+                 E.where_ $ allocationNotificationSetting E.^. AllocationNotificationSettingUser E.==. user E.^. UserId
+                      E.&&. allocationNotificationSetting E.^. AllocationNotificationSettingAllocation E.==. E.val nAllocation
+                      E.&&. E.not_ (allocationNotificationSetting E.^. AllocationNotificationSettingIsOptOut)
+
+           E.where_ . allocationNotifyNewCourses (E.val nAllocation) $ user E.^. UserId
+
+           E.where_ . E.not_ . E.exists . E.from $ \application ->
+             E.where_ $ application E.^. CourseApplicationAllocation E.==. E.justVal nAllocation
+                  E.&&. application E.^. CourseApplicationUser E.==. user E.^. UserId
+                  E.&&. application E.^. CourseApplicationCourse E.==. E.val nCourse
+           
+           return (hasOverride, user)
 
 
 classifyNotification :: Notification -> DB NotificationTrigger
@@ -315,3 +334,4 @@ classifyNotification NotificationCourseRegistered{}               = return NTCou
 classifyNotification NotificationSubmissionEdited{}               = return NTSubmissionEdited
 classifyNotification NotificationSubmissionUserCreated{}          = return NTSubmissionUserCreated
 classifyNotification NotificationSubmissionUserDeleted{}          = return NTSubmissionUserDeleted
+classifyNotification NotificationAllocationNewCourse{}            = return NTAllocationNewCourse

src/Jobs/Handler/SendNotification/Allocation.hs

@@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.Allocation
   , dispatchNotificationAllocationAllocation
   , dispatchNotificationAllocationUnratedApplications
   , dispatchNotificationAllocationResults
+  , dispatchNotificationAllocationNewCourse
   ) where
 
 import Import
@@ -183,3 +184,24 @@ dispatchNotificationAllocationResults nAllocation jRecipient = userMailT jRecipi
   editNotifications <- mkEditNotifications jRecipient
 
   addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationResults.hamlet")
+
+dispatchNotificationAllocationNewCourse :: AllocationId -> CourseId -> UserId -> Handler ()
+dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMailT jRecipient $ do
+  (Allocation{..}, Course{..}, hasApplied) <- liftHandler . runDB $ (,,)
+    <$> getJust nAllocation
+    <*> getJust nCourse
+    <*> exists [CourseApplicationAllocation ==. Just nAllocation, CourseApplicationUser ==. jRecipient]
+
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  setSubjectI $ MsgMailSubjectAllocationNewCourse allocationName
+  editNotifications <- mkEditNotifications jRecipient
+
+  cID <- encrypt nCourse
+  mayApply <- orM
+    [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True
+    , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True
+    ]
+
+  allocUrl <- toTextUrl $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR :#: cID
+
+  addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/allocationNewCourse.hamlet")

src/Jobs/Types.hs

@@ -43,83 +43,86 @@ import System.Clock (getTime, Clock(Monotonic), TimeSpec)
 import GHC.Conc (unsafeIOToSTM)
 
 
-data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+data Job
-         | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
+  = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
-         | JobQueueNotification { jNotification :: Notification }
+  | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
-         | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
+  | JobQueueNotification { jNotification :: Notification }
-                          , jRequestTime :: UTCTime
+  | JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
-                          , jSubject :: Maybe Text
+                   , jRequestTime :: UTCTime
-                          , jHelpRequest :: Maybe Html
+                   , jSubject :: Maybe Text
-                          , jReferer :: Maybe Text
+                   , jHelpRequest :: Maybe Html
-                          , jError :: Maybe ErrorResponse
+                   , jReferer :: Maybe Text
-                          }
+                   , jError :: Maybe ErrorResponse
-         | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
+                   }
-         | JobDistributeCorrections { jSheet :: SheetId }
+  | JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
-         | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
+  | JobDistributeCorrections { jSheet :: SheetId }
-                                      , jAllRecipientAddresses :: Set Address
+  | JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
-                                      , jCourse :: CourseId
+                               , jAllRecipientAddresses :: Set Address
-                                      , jSender :: UserId
+                               , jCourse :: CourseId
-                                      , jMailObjectUUID :: UUID
+                               , jSender :: UserId
-                                      , jSubject :: Maybe Text
+                               , jMailObjectUUID :: UUID
-                                      , jMailContent :: Html
+                               , jSubject :: Maybe Text
-                                      }
+                               , jMailContent :: Html
-         | JobInvitation { jInviter :: Maybe UserId
+                               }
-                         , jInvitee :: UserEmail
+  | JobInvitation { jInviter :: Maybe UserId
-                         , jInvitationUrl :: Text
+                  , jInvitee :: UserEmail
-                         , jInvitationSubject :: Text
+                  , jInvitationUrl :: Text
-                         , jInvitationExplanation :: Html
+                  , jInvitationSubject :: Text
+                  , jInvitationExplanation :: Html
+                  }
+  | JobSendPasswordReset { jRecipient :: UserId
                          }
-         | JobSendPasswordReset { jRecipient :: UserId
+  | JobTruncateTransactionLog
-                                }
+  | JobPruneInvitations
-         | JobTruncateTransactionLog
+  | JobDeleteTransactionLogIPs
-         | JobPruneInvitations
+  | JobSynchroniseLdap { jNumIterations
-         | JobDeleteTransactionLogIPs
+                       , jEpoch
-         | JobSynchroniseLdap { jNumIterations
+                       , jIteration :: Natural
+                       }
+  | JobSynchroniseLdapUser { jUser :: UserId
+                           }
+  | JobChangeUserDisplayEmail { jUser :: UserId
+                              , jDisplayEmail :: UserEmail
+                              }
+  | JobPruneSessionFiles
+  | JobPruneUnreferencedFiles { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
                               }
-         | JobSynchroniseLdapUser { jUser :: UserId
+  | JobInjectFiles
-                                  }
+  | JobPruneFallbackPersonalisedSheetFilesKeys
-         | JobChangeUserDisplayEmail { jUser :: UserId
+  | JobRechunkFiles
-                                     , jDisplayEmail :: UserEmail
+  | JobDetectMissingFiles
-                                     }
-         | JobPruneSessionFiles
-         | JobPruneUnreferencedFiles { jNumIterations
-                                     , jEpoch
-                                     , jIteration :: Natural
-                                     }
-         | JobInjectFiles
-         | JobPruneFallbackPersonalisedSheetFilesKeys
-         | JobRechunkFiles
-         | JobDetectMissingFiles
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
-data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
+data Notification
-                  | NotificationSheetActive { nSheet :: SheetId }
+  = NotificationSubmissionRated { nSubmission :: SubmissionId }
-                  | NotificationSheetSoonInactive { nSheet :: SheetId }
+  | NotificationSheetActive { nSheet :: SheetId }
-                  | NotificationSheetInactive { nSheet :: SheetId }
+  | NotificationSheetSoonInactive { nSheet :: SheetId }
-                  | NotificationSheetHint { nSheet :: SheetId }
+  | NotificationSheetInactive { nSheet :: SheetId }
-                  | NotificationSheetSolution { nSheet :: SheetId }
+  | NotificationSheetHint { nSheet :: SheetId }
-                  | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
+  | NotificationSheetSolution { nSheet :: SheetId }
-                  | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
+  | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
-                  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
+  | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
-                  | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
+  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
-                  | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
+  | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
-                  | NotificationExamRegistrationActive { nExam :: ExamId }
+  | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
-                  | NotificationExamRegistrationSoonInactive { nExam :: ExamId }
+  | NotificationExamRegistrationActive { nExam :: ExamId }
-                  | NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
+  | NotificationExamRegistrationSoonInactive { nExam :: ExamId }
-                  | NotificationExamResult { nExam :: ExamId }
+  | NotificationExamDeregistrationSoonInactive { nExam :: ExamId }
-                  | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId }
+  | NotificationExamResult { nExam :: ExamId }
-                  | NotificationAllocationRegister { nAllocations :: Set AllocationId }
+  | NotificationAllocationStaffRegister { nAllocations :: Set AllocationId }
-                  | NotificationAllocationAllocation { nAllocations :: Set AllocationId }
+  | NotificationAllocationRegister { nAllocations :: Set AllocationId }
-                  | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId }
+  | NotificationAllocationAllocation { nAllocations :: Set AllocationId }
-                  | NotificationExamOfficeExamResults { nExam :: ExamId }
+  | NotificationAllocationUnratedApplications { nAllocations :: Set AllocationId }
-                  | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
+  | NotificationAllocationNewCourse { nAllocation :: AllocationId, nCourse :: CourseId }
-                  | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
+  | NotificationExamOfficeExamResults { nExam :: ExamId }
-                  | NotificationAllocationResults { nAllocation :: AllocationId }
+  | NotificationExamOfficeExamResultsChanged { nExamResults :: Set ExamResultId }
-                  | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
+  | NotificationExamOfficeExternalExamResults { nExternalExam :: ExternalExamId }
-                  | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
+  | NotificationAllocationResults { nAllocation :: AllocationId }
-                  | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
+  | NotificationCourseRegistered { nUser :: UserId, nCourse :: CourseId }
-                  | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
+  | NotificationSubmissionEdited { nInitiator :: UserId, nSubmission :: SubmissionId }
+  | NotificationSubmissionUserCreated { nUser :: UserId, nSubmission :: SubmissionId }
+  | NotificationSubmissionUserDeleted { nUser :: UserId, nSheet :: SheetId, nSubmission :: SubmissionId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job

src/Model/Migration.hs

@@ -45,6 +45,10 @@ import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorag
   
 import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
 
+import Data.Time.Format.ISO8601 (iso8601Show)
+
+import qualified Data.Time.Zones as TZ
+
 -- Database versions must follow https://pvp.haskell.org:
 --   - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
 --   - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
@@ -168,6 +172,19 @@ migrateManual = do
     , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        )
     , ("file_content_entry_chunk_hash",       "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)"        )
     ]
+
+  recordedChangelogItems <- lift . lift $ selectList [] []
+  let missingChangelogItems = Set.toList $ Set.fromList universeF `Set.difference` recordedChangelogItems'
+        where recordedChangelogItems' = Set.fromList [ changelogItemFirstSeenItem | Entity _ ChangelogItemFirstSeen{..} <- recordedChangelogItems ]
+  unless (null missingChangelogItems) $ do
+    now <- iso8601Show . localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
+    addMigration False $
+      let sql = [st|INSERT INTO changelog_item_first_seen (item, first_seen) VALUES #{vals}|]
+          vals = Text.intercalate ", " $ do
+            item <- missingChangelogItems
+            return [st|('#{toPathPiece item}', '#{now}')|]
+       in sql
+
   where
     addIndex :: Text -> Sql -> Migration
     addIndex ixName ixDef = do
@@ -950,6 +967,26 @@ customMigrations = Map.fromListWith (>>)
           INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|41.0.0|] [version|42.0.0|]
+    , do
+        whenM (tableExists "exam")
+          [executeQQ|
+            ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing};
+          |]
+        whenM (tableExists "school")
+          [executeQQ|
+            ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse};
+          |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|42.0.0|] [version|43.0.0|]
+    , unlessM (tableExists "changelog_item_first_seen") $ do
+        [executeQQ|
+          CREATE TABLE "changelog_item_first_seen" (PRIMARY KEY ("item"), "item" VARCHAR NOT NULL, "first_seen" DATE NOT NULL);
+        |]
+        insertMany_ [ ChangelogItemFirstSeen{..}
+                    | (changelogItemFirstSeenItem, changelogItemFirstSeenFirstSeen) <- Map.toList changelogItemDays
+                    ]
+    )
   ]
 
 

src/Model/Types.hs

@@ -18,3 +18,4 @@ import Model.Types.Languages as Types
 import Model.Types.File as Types
 import Model.Types.User as Types
 import Model.Types.Workflow as Types
+import Model.Types.Changelog as Types

src/Model/Types/Changelog.hs

@@ -0,0 +1,145 @@
+module Model.Types.Changelog
+  ( ChangelogItem(..)
+  , changelogItemMap
+  , ChangelogItemKind(..), _ChangelogItemFeature, _ChangelogItemBugfix
+  , classifyChangelogItem
+  , changelogItemDays
+  ) where
+
+import Import.NoModel
+
+import Model.Types.TH.PathPiece
+
+import qualified Data.Map as Map
+
+
+mkI18nWidgetEnum "Changelog" "changelog"
+derivePersistFieldPathPiece ''ChangelogItem
+pathPieceJSONKey ''ChangelogItem
+pathPieceJSON ''ChangelogItem
+pathPieceHttpApiData ''ChangelogItem
+
+data ChangelogItemKind 
+  = ChangelogItemFeature
+  | ChangelogItemBugfix
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+makePrisms ''ChangelogItemKind
+
+classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
+classifyChangelogItem = \case
+  ChangelogHaskellCampusLogin                    -> ChangelogItemBugfix
+  ChangelogTooltipsWithoutJavascript             -> ChangelogItemBugfix
+  ChangelogButtonsWorkWithoutJavascript          -> ChangelogItemBugfix
+  ChangelogTableFormsWorkAfterAjax               -> ChangelogItemBugfix
+  ChangelogPassingByPointsWorks                  -> ChangelogItemBugfix
+  ChangelogErrorMessagesForTableItemVanish       -> ChangelogItemBugfix
+  ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
+  ChangelogFormsTimesReset                       -> ChangelogItemBugfix
+  _other                                         -> ChangelogItemFeature
+
+changelogItemDays :: Map ChangelogItem Day
+changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
+  [ (ChangelogConfigurableDatetimeFormat,                      [day|2018-07-10|])
+  , (ChangelogCourseListOverAllTerms,                          [day|2018-07-31|])
+  , (ChangelogCorrectionsDisplayImprovements,                  [day|2018-07-31|])
+  , (ChangelogHaskellCampusLogin,                              [day|2018-08-01|])
+  , (ChangelogFileDownloadOption,                              [day|2018-08-06|])
+  , (ChangelogSheetsNoSubmissionAndZipControl,                 [day|2018-09-18|])
+  , (ChangelogSmartCorrectionDistribution,                     [day|2018-09-18|])
+  , (ChangelogTableSummaries,                                  [day|2018-09-18|])
+  , (ChangelogPersonalInformation,                             [day|2018-09-18|])
+  , (ChangelogCourseShorthandsWithinSchools,                   [day|2018-09-18|])
+  , (ChangelogTooltipsWithoutJavascript,                       [day|2018-09-18|])
+  , (ChangelogEmailNotifications,                              [day|2018-10-19|])
+  , (ChangelogSupportWidget,                                   [day|2018-10-19|])
+  , (ChangelogAccountDeletionDuringTesting,                    [day|2018-10-19|])
+  , (ChangelogImprovementsForCorrectors,                       [day|2018-11-09|])
+  , (ChangelogButtonsWorkWithoutJavascript,                    [day|2018-11-09|])
+  , (ChangelogTableFormsWorkAfterAjax,                         [day|2018-11-29|])
+  , (ChangelogPassingByPointsWorks,                            [day|2018-11-30|])
+  , (ChangelogErrorMessagesForTableItemVanish,                 [day|2019-01-16|])
+  , (ChangelogAssignedCorrectionsFilters,                      [day|2019-01-16|])
+  , (ChangelogCourseConvenienceLinks,                          [day|2019-01-16|])
+  , (ChangelogAsidenav,                                        [day|2019-01-30|])
+  , (ChangelogCourseAssociatedStudyField,                      [day|2019-03-20|])
+  , (ChangelogStudyFeatures,                                   [day|2019-03-27|])
+  , (ChangelogCourseAdministratorRoles,                        [day|2019-03-27|])
+  , (ChangelogCourseAdministratorInvitations,                  [day|2019-04-20|])
+  , (ChangelogCourseMessages,                                  [day|2019-04-20|])
+  , (ChangelogCorrectorsOnCourseShow,                          [day|2019-04-29|])
+  , (ChangelogTutorials,                                       [day|2019-04-29|])
+  , (ChangelogCourseMaterials,                                 [day|2019-05-04|])
+  , (ChangelogDownloadAllSheetFiles,                           [day|2019-05-10|])
+  , (ChangelogImprovedSubmittorUi,                             [day|2019-05-10|])
+  , (ChangelogCourseRegisterByAdmin,                           [day|2019-05-13|])
+  , (ChangelogReworkedAutomaticCorrectionDistribution,         [day|2019-05-20|])
+  , (ChangelogDownloadAllSheetFilesByType,                     [day|2019-06-07|])
+  , (ChangelogSheetSpecificFiles,                              [day|2019-06-07|])
+  , (ChangelogExams,                                           [day|2019-06-26|])
+  , (ChangelogCsvExamParticipants,                             [day|2019-07-23|])
+  , (ChangelogAllocationCourseRegistration,                    [day|2019-08-12|])
+  , (ChangelogAllocationApplications,                          [day|2019-08-19|])
+  , (ChangelogCsvCourseApplications,                           [day|2019-08-27|])
+  , (ChangelogAllocationsNotifications,                        [day|2019-09-05|])
+  , (ChangelogConfigurableDisplayEmails,                       [day|2019-09-12|])
+  , (ChangelogConfigurableDisplayNames,                        [day|2019-09-12|])
+  , (ChangelogEstimateAllocatedCourseCapacity,                 [day|2019-09-12|])
+  , (ChangelogNotificationExamRegistration,                    [day|2019-09-13|])
+  , (ChangelogExamClosure,                                     [day|2019-09-16|])
+  , (ChangelogExamOfficeExamNotification,                      [day|2019-09-16|])
+  , (ChangelogExamOffices,                                     [day|2019-09-16|])
+  , (ChangelogExamAchievementParticipantDuplication,           [day|2019-09-25|])
+  , (ChangelogFormsTimesReset,                                 [day|2019-09-25|])
+  , (ChangelogExamAutomaticResults,                            [day|2019-09-25|])
+  , (ChangelogExamAutomaticBoni,                               [day|2019-09-25|])
+  , (ChangelogAutomaticallyAcceptCourseApplications,           [day|2019-09-27|])
+  , (ChangelogCourseNews,                                      [day|2019-10-01|])
+  , (ChangelogCsvExportCourseParticipants,                     [day|2019-10-08|])
+  , (ChangelogNotificationCourseParticipantViaAdmin,           [day|2019-10-08|])
+  , (ChangelogCsvExportCourseParticipantsFeatures,             [day|2019-10-09|])
+  , (ChangelogCourseOccurences,                                [day|2019-10-09|])
+  , (ChangelogTutorialRegistrationViaParticipantTable,         [day|2019-10-10|])
+  , (ChangelogCsvExportCourseParticipantsRegisteredTutorials,  [day|2019-10-10|])
+  , (ChangelogCourseParticipantsSex,                           [day|2019-10-14|])
+  , (ChangelogTutorialTutorControl,                            [day|2019-10-14|])
+  , (ChangelogCsvOptionCharacterSet,                           [day|2019-10-23|])
+  , (ChangelogCsvOptionTimestamp,                              [day|2019-10-23|])
+  , (ChangelogEnglish,                                         [day|2019-10-31|])
+  , (ChangelogI18n,                                            [day|2019-10-31|])
+  , (ChangelogLmuInternalFields,                               [day|2019-11-28|])
+  , (ChangelogNotificationSubmissionChanged,                   [day|2019-12-05|])
+  , (ChangelogExportCourseParticipants,                        [day|2020-01-17|])
+  , (ChangelogExternalExams,                                   [day|2020-01-17|])
+  , (ChangelogExamAutomaticRoomDistribution,                   [day|2020-01-29|])
+  , (ChangelogWarningMultipleSemesters,                        [day|2020-01-30|])
+  , (ChangelogExamAutomaticRoomDistributionBetterRulesDisplay, [day|2020-01-30|])
+  , (ChangelogReworkedNavigation,                              [day|2020-02-07|])
+  , (ChangelogExamCorrect,                                     [day|2020-02-08|])
+  , (ChangelogExamGradingMode,                                 [day|2020-02-19|])
+  , (ChangelogMarkdownEmails,                                  [day|2020-02-23|])
+  , (ChangelogMarkdownHtmlInput,                               [day|2020-02-23|])
+  , (ChangelogBetterCsvImport,                                 [day|2020-03-06|])
+  , (ChangelogAdditionalDatetimeFormats,                       [day|2020-03-16|])
+  , (ChangelogServerSideSessions,                              [day|2020-03-16|])
+  , (ChangelogWebinterfaceAllocationAllocation,                [day|2020-03-16|])
+  , (ChangelogBetterTableCellColourCoding,                     [day|2020-03-16|])
+  , (ChangelogCourseOccurrenceNotes,                           [day|2020-03-31|])
+  , (ChangelogHideSystemMessages,                              [day|2020-04-15|])
+  , (ChangelogNonAnonymisedCorrection,                         [day|2020-04-17|])
+  , (ChangelogBetterCourseParticipantDetailPage,               [day|2020-04-17|])
+  , (ChangelogFaq,                                             [day|2020-04-24|])
+  , (ChangelogRegisteredSubmissionGroups,                      [day|2020-04-28|])
+  , (ChangelogFormerCourseParticipants,                        [day|2020-05-05|])
+  , (ChangelogBetterFileUploads,                               [day|2020-05-05|])
+  , (ChangelogSheetPassAlways,                                 [day|2020-05-23|])
+  , (ChangelogBetterCourseCommunicationTutorials,              [day|2020-05-25|])
+  , (ChangelogAdditionalSheetNotifications,                    [day|2020-05-25|])
+  , (ChangelogCourseParticipantsListAddSheets,                 [day|2020-06-14|])
+  , (ChangelogYamlRatings,                                     [day|2020-06-17|])
+  , (ChangelogSubmissionOnlyExamRegistered,                    [day|2020-07-20|])
+  , (ChangelogCourseVisibility,                                [day|2020-08-10|])
+  , (ChangelogPersonalisedSheetFiles,                          [day|2020-08-10|])
+  , (ChangelogAbolishCourseAssociatedStudyFeatures,            [day|2020-08-28|])
+  ]

src/Model/Types/Exam.hs

@@ -32,6 +32,12 @@ module Model.Types.Exam
   , hasExamGradingPass, hasExamGradingGrades
   , ExamPartNumber
   , _ExamPartNumber, _ExamPartNumber'
+  , ExamAids(..), ExamAidsPreset(..)
+  , ExamOnline(..), ExamOnlinePreset(..)
+  , ExamSynchronicity(..), ExamSynchronicityPreset(..)
+  , ExamRequiredEquipment(..), ExamRequiredEquipmentPreset(..)
+  , ExamMode(..)
+  , ExamModePredicate(..), ExamModeDNF(..)
   ) where
 
 import Import.NoModel
@@ -59,6 +65,8 @@ import qualified Data.Foldable
 
 import Data.Aeson (genericToJSON, genericParseJSON)
 
+import Model.Types.Security
+
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 
 
@@ -427,3 +435,125 @@ pathPieceJSONKey ''ExamPartNumber
 instance Enum ExamPartNumber where
   toEnum = review _ExamPartNumber' . toEnum
   fromEnum = maybe (error "Converting non-numeric ExamPartNumber to Int") fromEnum . preview _ExamPartNumber'
+
+
+data ExamAids
+  = ExamAidsPreset { examAidsPreset :: ExamAidsPreset }
+  | ExamAidsCustom { examAidsCustom :: Html }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data ExamAidsPreset
+  = ExamOpenBook
+  | ExamClosedBook
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = TaggedObject "mode" "data"
+  } ''ExamAids
+derivePersistFieldJSON ''ExamAids
+
+nullaryPathPiece' ''ExamAidsPreset $ nameToPathPiece' 1
+pathPieceJSON ''ExamAidsPreset
+
+data ExamOnline
+  = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset }
+  | ExamOnlineCustom { examOnlineCustom :: Html }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data ExamOnlinePreset
+  = ExamOnline
+  | ExamOffline
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = TaggedObject "mode" "data"
+  } ''ExamOnline
+derivePersistFieldJSON ''ExamOnline
+
+nullaryPathPiece' ''ExamOnlinePreset $ nameToPathPiece' 1
+pathPieceJSON ''ExamOnlinePreset
+
+data ExamSynchronicity
+  = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset }
+  | ExamSynchronicityCustom { examSynchronicityCustom :: Html }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data ExamSynchronicityPreset
+  = ExamSynchronous
+  | ExamAsynchronous
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = TaggedObject "mode" "data"
+  } ''ExamSynchronicity
+derivePersistFieldJSON ''ExamSynchronicity
+
+nullaryPathPiece' ''ExamSynchronicityPreset $ nameToPathPiece' 1
+pathPieceJSON ''ExamSynchronicityPreset
+
+data ExamRequiredEquipment
+  = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset }
+  | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: Html }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+data ExamRequiredEquipmentPreset
+  = ExamRequiredEquipmentNone
+  | ExamRequiredEquipmentPen
+  | ExamRequiredEquipmentPaperPen
+  | ExamRequiredEquipmentCalculatorPen
+  | ExamRequiredEquipmentCalculatorPaperPen
+  | ExamRequiredEquipmentWebcamMicrophoneInternet
+  | ExamRequiredEquipmentMicrophoneInternet
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 2
+  , fieldLabelModifier = camelToPathPiece' 2
+  , sumEncoding = TaggedObject "mode" "data"
+  } ''ExamRequiredEquipment
+derivePersistFieldJSON ''ExamRequiredEquipment
+
+nullaryPathPiece' ''ExamRequiredEquipmentPreset $ nameToPathPiece' 3
+pathPieceJSON ''ExamRequiredEquipmentPreset
+
+
+data ExamMode = ExamMode
+  { examAids :: Maybe ExamAids
+  , examOnline :: Maybe ExamOnline
+  , examSynchronicity :: Maybe ExamSynchronicity
+  , examRequiredEquipment :: Maybe ExamRequiredEquipment
+  }
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , sumEncoding = UntaggedValue
+  } ''ExamMode
+derivePersistFieldJSON ''ExamMode
+
+data ExamModePredicate
+  = ExamModePredAids ExamAidsPreset
+  | ExamModePredOnline ExamOnlinePreset
+  | ExamModePredSynchronicity ExamSynchronicityPreset
+  | ExamModePredRequiredEquipment ExamRequiredEquipmentPreset
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 3
+  , sumEncoding = TaggedObject "setting" "preset"
+  } ''ExamModePredicate
+derivePathPiece ''ExamModePredicate (camelToPathPiece' 3) "--"
+deriveFinite ''ExamModePredicate
+
+newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece)
+
+derivePersistFieldJSON ''ExamModeDNF

src/Model/Types/Mail.hs

@@ -43,6 +43,7 @@ data NotificationTrigger
   | NTAllocationStaffRegister
   | NTAllocationAllocation
   | NTAllocationRegister
+  | NTAllocationNewCourse
   | NTAllocationOutdatedRatings
   | NTAllocationUnratedApplications
   | NTAllocationResults
@@ -72,6 +73,7 @@ instance Default NotificationSettings where
       defaultOff = HashSet.fromList
         [ NTSheetSoonInactive
         , NTExamRegistrationSoonInactive
+        , NTAllocationNewCourse
         ]
 
 instance ToJSON NotificationSettings where

src/Model/Types/Security.hs

@@ -184,6 +184,9 @@ dnfAssumeValue var val
     disagrees PLNegated{..}  = plVar == var && val
     disagrees PLVariable{..} = plVar == var && not val
 
+predDNFFalse :: PredDNF a
+predDNFFalse = PredDNF Set.empty
+
 
 data UserGroupName
   = UserGroupMetrics

src/Settings.hs

@@ -12,6 +12,7 @@ module Settings
   , module Settings.Mime
   , module Settings.Cookies
   , module Settings.Log
+  , module Settings.Locale
   ) where
 
 import           Import.NoModel
@@ -55,6 +56,7 @@ import Settings.Cluster
 import Settings.Mime
 import Settings.Cookies
 import Settings.Log
+import Settings.Locale
 
 import qualified System.FilePath as FilePath
 
@@ -605,10 +607,3 @@ compileTimeAppSettings =
     case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
         Aeson.Error e -> error e
         Aeson.Success settings -> settings
-
-
-getTimeLocale' :: [Lang] -> TimeLocale
-getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
-
-appTZ :: TZ
-appTZ = $(includeSystemTZ "Europe/Berlin")

src/Settings/Locale.hs

@@ -0,0 +1,21 @@
+module Settings.Locale
+  ( getTimeLocale'
+  , appTZ
+  , appLanguages
+  ) where
+
+import Utils.DateTime
+
+import Data.List.NonEmpty
+
+import Text.Shakespeare.I18N (Lang)
+  
+
+getTimeLocale' :: [Lang] -> TimeLocale
+getTimeLocale' = $(timeLocaleMap [("de-de", "de_DE.utf8"), ("en-GB", "en_GB.utf8")])
+
+appTZ :: TZ
+appTZ = $(includeSystemTZ "Europe/Berlin")
+
+appLanguages :: NonEmpty Lang
+appLanguages = "de-de-formal" :| ["en-eu"]

src/Utils.hs

@@ -32,6 +32,7 @@ import Utils.Cookies.Registered as Utils
 import Utils.Session as Utils
 import Utils.Csv as Utils
 import Utils.I18n as Utils
+import Utils.NTop as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -115,7 +116,7 @@ import qualified Control.Monad.Random.Lazy as LazyRand
 import Data.Data (Data)
 import qualified Data.Text.Lazy.Builder as Builder
 
-import Unsafe.Coerce
+import Data.Coerce
 
 import System.FilePath as Utils (addExtension, isExtensionOf)
 import System.FilePath (dropDrive)
@@ -660,16 +661,7 @@ ignoreNothing _ Nothing y = y
 ignoreNothing _ x Nothing = x
 ignoreNothing f (Just x) (Just y) = Just $ f x y
 
-newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+-- `NTop` moved to `Utils.NTop`
-
-instance Eq a  => Eq (NTop (Maybe a)) where
-  (NTop x) == (NTop y) = x == y
-
-instance Ord a => Ord (NTop (Maybe a)) where
-  compare (NTop Nothing)  (NTop Nothing) = EQ
-  compare (NTop Nothing)  _              = GT
-  compare _               (NTop Nothing) = LT
-  compare (NTop (Just x)) (NTop (Just y)) = compare x y
 
 exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
 exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
@@ -1264,8 +1256,8 @@ instance (Eq k, Hashable k, Semigroup v) => Monoid (MergeHashMap k v) where
   mempty = MergeHashMap HashMap.empty
 instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeHashMap k v) where
   parseJSON = case Aeson.fromJSONKey of
-      Aeson.FromJSONKeyCoerce _ -> Aeson.withObject "HashMap ~Text" $
+      Aeson.FromJSONKeyCoerce -> Aeson.withObject "HashMap ~Text" $
-          uc . HashMap.traverseWithKey (\k v -> parseJSON v Aeson.<?> Aeson.Key k)
+          coerce @(Aeson.Parser (HashMap k v)) @(Aeson.Parser (MergeHashMap k v)) . fmap HashMap.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
       Aeson.FromJSONKeyText f -> Aeson.withObject "HashMap" $
           fmap MergeHashMap . HashMap.foldrWithKey (\k v m -> HashMap.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty)
       Aeson.FromJSONKeyTextParser f -> Aeson.withObject "HashMap" $
@@ -1273,9 +1265,6 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
       Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
           fmap (MergeHashMap . HashMap.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
     where
-      uc :: Aeson.Parser (HashMap Text v) -> Aeson.Parser (MergeHashMap k v)
-      uc = unsafeCoerce
-
       parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
       parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
         where
@@ -1290,6 +1279,61 @@ instance (Eq k, Hashable k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON
       parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
       parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
 
+
+newtype MergeMap k v = MergeMap { unMergeMap :: Map k v }
+  deriving (Show, Generic, Typeable, Data)
+  deriving newtype ( Eq, Ord
+                   , Functor, Foldable, NFData
+                   , ToJSON
+                   )
+
+makePrisms ''MergeMap
+makeWrapped ''MergeMap
+
+type instance Element (MergeMap k v) = v
+  
+instance MonoFoldable (MergeMap k v)
+instance MonoFunctor (MergeMap k v)
+instance MonoTraversable (MergeMap k v)
+
+instance Traversable (MergeMap k) where
+  traverse = _MergeMap . traverse
+
+instance FunctorWithIndex k (MergeMap k)
+instance TraversableWithIndex k (MergeMap k) where
+  itraverse = _MergeMap .> itraverse
+instance FoldableWithIndex k (MergeMap k)
+
+instance (Ord k, Semigroup v) => Semigroup (MergeMap k v) where
+  (MergeMap a) <> (MergeMap b) = MergeMap $ Map.unionWith (<>) a b
+instance (Ord k, Semigroup v) => Monoid (MergeMap k v) where
+  mempty = MergeMap Map.empty
+instance (Ord k, FromJSON v, FromJSONKey k, Semigroup v) => FromJSON (MergeMap k v) where
+  parseJSON = case Aeson.fromJSONKey of
+      Aeson.FromJSONKeyCoerce -> Aeson.withObject "Map ~Text" $
+          coerce @(Aeson.Parser (Map k v)) @(Aeson.Parser (MergeMap k v)) . fmap Map.fromList . traverse (\(k, v) -> (coerce @Text @k k, ) <$> parseJSON v Aeson.<?> Aeson.Key k) . HashMap.toList
+      Aeson.FromJSONKeyText f -> Aeson.withObject "Map" $
+          fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) (f k) <$> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
+      Aeson.FromJSONKeyTextParser f -> Aeson.withObject "Map" $
+          fmap MergeMap . Map.foldrWithKey (\k v m -> Map.insertWith (<>) <$> f k Aeson.<?> Aeson.Key k <*> parseJSON v Aeson.<?> Aeson.Key k <*> m) (pure mempty) . Map.fromList . HashMap.toList
+      Aeson.FromJSONKeyValue f -> Aeson.withArray "Map" $ \arr ->
+          fmap (MergeMap . Map.fromListWith (<>)) . zipWithM (parseIndexedJSONPair f parseJSON) [0..] $ otoList arr
+    where
+      parseIndexedJSONPair :: (Value -> Aeson.Parser a) -> (Value -> Aeson.Parser b) -> Int -> Value -> Aeson.Parser (a, b)
+      parseIndexedJSONPair keyParser valParser idx value = p value Aeson.<?> Aeson.Index idx
+        where
+          p = Aeson.withArray "(k, v)" $ \ab ->
+              let n = V.length ab
+              in if n == 2
+                   then (,) <$> parseJSONElemAtIndex keyParser 0 ab
+                            <*> parseJSONElemAtIndex valParser 1 ab
+                   else fail $ "cannot unpack array of length " ++
+                               show n ++ " into a pair"
+
+      parseJSONElemAtIndex :: (Value -> Aeson.Parser a) -> Int -> Vector Value -> Aeson.Parser a
+      parseJSONElemAtIndex p idx ary = p (V.unsafeIndex ary idx) Aeson.<?> Aeson.Index idx
+
+  
 --------------
 -- FilePath --
 --------------

src/Utils/DateTime.hs

@@ -12,6 +12,7 @@ module Utils.DateTime
   , nominalHour, nominalMinute
   , minNominalYear, avgNominalYear
   , module Zones
+  , day
   ) where
 
 import ClassyPrelude.Yesod hiding (lift)
@@ -23,12 +24,14 @@ import Data.Time.Zones.TH as Zones (includeSystemTZ)
 import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime)
 import Data.Time.Format (FormatTime)
 import Data.Time.Clock.System (systemEpochDay)
+import qualified Data.Time.Format.ISO8601 as Time
 import qualified Data.Time.Format as Time
 
 import qualified Data.List.NonEmpty as NonEmpty
 
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax (Lift(..))
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
 import Instances.TH.Lift ()
 
 import Data.Data (Data)
@@ -45,6 +48,8 @@ import Algebra.Lattice.Ordered
 
 import Control.Monad.Fail
 
+import Utils.Lang (selectLanguage')
+
 
 -- $(timeLocaleMap _) :: [Lang] -> TimeLocale
 timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@@ -142,3 +147,15 @@ nominalMinute = 60
 minNominalYear, avgNominalYear :: NominalDiffTime
 minNominalYear = 365 * nominalDay
 avgNominalYear = fromRational $ 365.2425 * toRational nominalDay
+
+---------
+-- Day --
+---------
+
+day :: QuasiQuoter
+day = QuasiQuoter{..}
+  where
+    quotePat = error "day used as pattern"
+    quoteType = error "day used as type"
+    quoteDec = error "day used as declaration"
+    quoteExp dStr = maybe (fail $ "Could not parse ISO8601 day: “" <> dStr <> "”") (lift :: Day -> Q Exp) $ Time.iso8601ParseM dStr

src/Utils/Form.hs

@@ -230,6 +230,8 @@ data FormIdentifier
   | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
   | FIDAllocationAccept
   | FIDTestDownload
+  | FIDAllocationRegister
+  | FIDAllocationNotification
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where

src/Utils/I18n.hs

@@ -6,19 +6,40 @@ module Utils.I18n
   , renderMessageI18n
   , i18nMessageFor
   , Element
+  , i18nWidgetFilesAvailable, i18nWidgetFilesAvailable'
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Settings.Locale (appLanguages)
 
 import qualified Data.Aeson as JSON
 import qualified Data.HashMap.Lazy as HashMap
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import Model.Types.TH.JSON
 
 import Data.Data (Data)
 
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qRunIO)
+import qualified Language.Haskell.TH.Syntax as TH
+
+import qualified Data.List as List
+import Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
+
+import qualified Data.Text as Text
+
+import System.FilePath
+import System.Directory (listDirectory)
+
+import Utils.NTop
+
+import Control.Lens (iforM)
+import Control.Monad.Fail (fail)
+
 
 data I18n a = I18n
   { i18nFallback :: a
@@ -79,3 +100,18 @@ i18nMessageFor :: ( MonadHandler m
                   )
                => [Lang] -> msg -> m I18nText
 i18nMessageFor ls msg = getsYesod $ flip (renderMessageI18n ls) msg
+
+
+i18nWidgetFilesAvailable' :: FilePath -> Q (Map Text (NonEmpty Text))
+i18nWidgetFilesAvailable' basename = do
+  let i18nDirectory = "templates" </> "i18n" </> basename
+  availableFiles <- qRunIO $ listDirectory i18nDirectory
+  let fileKinds' = fmap (pack . dropExtension . takeBaseName &&& toTranslation . pack . takeBaseName) availableFiles
+      fileKinds :: Map Text [Text]
+      fileKinds = sortWith (NTop . flip List.elemIndex (NonEmpty.toList appLanguages)) . Set.toList <$> Map.fromListWith Set.union [ (kind, Set.singleton l) | (kind, Just l) <- fileKinds' ]
+      toTranslation fName = (listToMaybe . sortOn length) (mapMaybe ((flip Text.stripPrefix fName . (<>".")) . fst) fileKinds')
+
+  iforM fileKinds $ \kind -> maybe (fail $ "‘" <> i18nDirectory <> "’ has no translations for ‘" <> unpack kind <> "’") return . NonEmpty.nonEmpty
+
+i18nWidgetFilesAvailable :: FilePath -> Q Exp
+i18nWidgetFilesAvailable = TH.lift <=< i18nWidgetFilesAvailable'

src/Utils/Icon.hs

@@ -86,6 +86,10 @@ data Icon
   | IconFileUploadSession
   | IconStandaloneFieldError
   | IconFileUser
+  | IconNotification | IconNoNotification
+  | IconAllocationRegister | IconAllocationRegistrationEdit
+  | IconAllocationApplicationEdit
+  | IconPersonalIdentification
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
 
 iconText :: Icon -> Text
@@ -150,6 +154,12 @@ iconText = \case
     IconFileUploadSession       -> "file-upload"
     IconStandaloneFieldError    -> "exclamation"
     IconFileUser                -> "file-user"
+    IconNotification            -> "envelope"
+    IconNoNotification          -> "times"
+    IconAllocationRegister      -> "user-plus"
+    IconAllocationRegistrationEdit -> "pencil-alt"
+    IconAllocationApplicationEdit -> "pencil-alt"
+    IconPersonalIdentification  -> "id-card"
 
 instance Universe Icon
 instance Finite   Icon

src/Utils/NTop.hs

@@ -0,0 +1,17 @@
+module Utils.NTop
+  ( NTop(..)
+  ) where
+
+import ClassyPrelude
+
+-- | treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+newtype NTop a = NTop { nBot :: a }
+  deriving (Read, Show, Generic, Typeable)
+  deriving newtype (Eq)
+
+instance Ord a => Ord (NTop (Maybe a)) where
+  compare (NTop Nothing)  (NTop Nothing) = EQ
+  compare (NTop Nothing)  _              = GT
+  compare _               (NTop Nothing) = LT
+  compare (NTop (Just x)) (NTop (Just y)) = compare x y
+

src/Utils/PathPiece.hs

@@ -8,6 +8,7 @@ module Utils.PathPiece
   , tuplePathPiece
   , pathPieceJSON, pathPieceJSONKey
   , pathPieceBinary
+  , pathPieceHttpApiData
   ) where
 
 import ClassyPrelude.Yesod
@@ -27,7 +28,7 @@ import qualified Data.HashMap.Strict as HashMap
 
 import Numeric.Natural
 
-import Data.List (foldl)
+import Data.List (nub, foldl)
 
 import Data.Aeson.Types
 import qualified Data.Aeson.Types as Aeson
@@ -37,6 +38,11 @@ import Control.Monad.Fail
 import Data.Binary (Binary)
 import qualified Data.Binary as Binary
 
+import Control.Lens
+import Data.Generics.Product.Types
+
+import Web.HttpApiData
+
 
 mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp)
 mkFiniteFromPathPiece finiteType = do
@@ -105,7 +111,7 @@ derivePathPiece adt mangle joinPP = do
              []
     finDecs =
       [ pragInlD mapName NoInline FunLike AllPhases
-      , sigD mapName [t|HashMap Text ([Text] -> Maybe $(conT adt))|]
+      , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $(typ))|]
       , funD mapName
         [ clause [] (normalB finClause) [] ]
       ]
@@ -123,8 +129,17 @@ derivePathPiece adt mangle joinPP = do
                      , match wildP (normalB [e|Nothing|]) []
                      ]
                    ]
+    typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars
+    iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes
+      where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars
+            usesVar ConstructorInfo{..} n
+              | n `elem` map tvarName constructorVars = False
+              | otherwise = any (elemOf types n) constructorFields
+            fieldTypes = nub $ concatMap constructorFields datatypeCons
+    tvarName (PlainTV n) = n
+    tvarName (KindedTV n _) = n
   sequence . (finDecs ++ ) . pure $
-    instanceD (cxt []) [t|PathPiece $(conT adt)|]
+    instanceD (cxt iCxt) [t|PathPiece $(typ)|]
       [ funD 'toPathPiece
           (map toClause datatypeCons)
       , funD 'fromPathPiece
@@ -217,3 +232,11 @@ pathPieceBinary tName
           get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece
           put = Binary.put . toPathPiece
       |]
+
+pathPieceHttpApiData :: Name -> DecsQ
+pathPieceHttpApiData tName
+  = [d| instance ToHttpApiData $(conT tName) where
+          toUrlPiece = toPathPiece
+        instance FromHttpApiData $(conT tName) where
+          parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece
+      |]

src/Utils/SystemMessage.hs

@@ -7,10 +7,9 @@ import Data.List (findIndex)
 
 
 getSystemMessage :: (MonadHandler m, BackendCompatible SqlReadBackend backend)
-                 => NonEmpty Lang -- ^ `appLanguages`
+                 => SystemMessageId
-                 -> SystemMessageId
                  -> ReaderT backend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
-getSystemMessage appLanguages smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
+getSystemMessage smId = withReaderT (projectBackend @SqlReadBackend) . runMaybeT $ do
   SystemMessage{..} <- MaybeT $ get smId
   translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
   let

src/Utils/TH.hs

@@ -13,8 +13,18 @@ import Language.Haskell.TH.Datatype
 
 import Data.List ((!!), foldl)
 
+import Control.Lens
 import Control.Monad.Fail
 
+import Utils.I18n
+
+import qualified Data.Char as Char
+import Data.Universe (Universe, Finite)
+import qualified Data.Map as Map
+import qualified Data.Text as Text
+
+import Utils.PathPiece
+
 ------------
 -- Tuples --
 ------------
@@ -188,3 +198,56 @@ dispatchTH dType = do
       let fName = mkName $ "dispatch" <> nameBase constructorName
       match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
   lamCaseE matches
+
+
+mkI18nWidgetEnum :: String -> FilePath -> DecsQ
+mkI18nWidgetEnum (splitCamel -> namebase) basename = do
+  itemsAvailable <- i18nWidgetFilesAvailable' basename
+  let items = Map.mapWithKey (\k _ -> typPrefix <> unPathPiece k) itemsAvailable
+  sequence
+    [ dataD (cxt []) dataName [] Nothing
+        [ normalC (mkName conName) []
+        | (_, conName) <- Map.toAscList items
+        ]
+        [ derivClause (Just StockStrategy)
+            [ conT ''Eq
+            , conT ''Ord
+            , conT ''Read
+            , conT ''Show
+            , conT ''Enum
+            , conT ''Bounded
+            , conT ''Generic
+            , conT ''Typeable
+            ]
+        , derivClause (Just AnyclassStrategy)
+            [ conT ''Universe
+            , conT ''Finite
+            ]
+        ]
+    , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)
+      [ funD 'toPathPiece
+        [ clause [conP (mkName con) []] (normalB . litE . stringL $ repack int) []
+        | (int, con) <- Map.toList items
+        ]
+      , funD 'fromPathPiece
+        [ clause [varP $ mkName "t"]
+          ( guardedB
+            [ (,) <$> normalG [e|$(varE $ mkName "t") == int|] <*> [e|Just $(conE $ mkName con)|]
+            | (int, con) <- Map.toList items
+            ]) []
+        , clause [wildP] (normalB [e|Nothing|]) []
+        ]
+      ]
+    , sigD (mkName $ valPrefix <> "ItemMap") [t|Map Text $(conT dataName)|]
+    , funD (mkName $ valPrefix <> "ItemMap")
+        [ clause [] (normalB [e| Map.fromList $(listE . map (\(int, con) -> tupE [litE . stringL $ repack int, conE $ mkName con]) $ Map.toList items) |]) []
+        ]
+    ]
+  where
+    unPathPiece :: Text -> String
+    unPathPiece = repack . mconcat . map (over _head Char.toUpper) . Text.splitOn "-"
+
+    dataName = mkName $ typPrefix <> "Item"
+
+    typPrefix = concat $ over (takingWhile Char.isLower $ _head . traverse) Char.toUpper namebase
+    valPrefix = concat $ over (takingWhile Char.isUpper $ _head . traverse) Char.toLower namebase

stack.yaml

@@ -73,6 +73,9 @@ extra-deps:
   - unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144
   - wai-middleware-prometheus-1.0.0@sha256:1625792914fb2139f005685be8ce519111451cfb854816e430fbf54af46238b4,1314
   - primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
+  - aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
+  - data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
+  - strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
 
 resolver: nightly-2020-08-08
 compiler: ghc-8.10.2

stack.yaml.lock

@@ -276,6 +276,27 @@ packages:
       sha256: 924e88629b493abb6b2f3c3029cef076554a2b627091e3bb6887ec03487a707d
   original:
     hackage: primitive-0.7.1.0@sha256:6a237bb338bcc43193077ff8e8c0f0ce2de14c652231496a15672e8b563a07e2,2604
+- completed:
+    hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
+    pantry-tree:
+      size: 39759
+      sha256: 6290ffac2ea3e52b57d869306d12dbf32c07d17099f695f035ff7f756677831d
+  original:
+    hackage: aeson-1.5.3.0@sha256:05496710de6ae694e55dc77dbdaf7503f56c24e4aecc06045e42e75a02df8bc4,6906
+- completed:
+    hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
+    pantry-tree:
+      size: 261
+      sha256: 6cf43af344624e087dbe2f1e96e985de6142e85bb02db8449df6d72bee3c1013
+  original:
+    hackage: data-fix-0.3.0@sha256:058a266d1e658500e0ffb8babe68195b0ce06a081dcfc3814afc784b083fd9a5,1645
+- completed:
+    hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
+    pantry-tree:
+      size: 654
+      sha256: fdf523b8990567d69277b999d68d492ed0b3a98a89b1acdfb3087e3b95eb9908
+  original:
+    hackage: strict-0.4@sha256:1b50c7c9c636c3a1bbc7f8873b9be48f6ca0faca4df6eec6a014de6208fb1c0e,4200
 snapshots:
 - completed:
     size: 524392

templates/allocation/show.hamlet

@@ -65,7 +65,7 @@ $newline never
       <dd .deflist__dd>
         <p>^{formatTimeW SelFormatDateTime toT}
 
-<section id=allocation-participation>
+<section #allocation-participation>
   <h2>
     _{MsgAllocationParticipation}
   $if is _Nothing muid
@@ -94,6 +94,18 @@ $newline never
       $# This redundant links prevents useless help requests from frantic users
       ^{allocationInfoModal}
 
+<section>
+  <h2>
+    _{MsgAllocationNotificationNewCourse}
+  $if is _Just muid
+    <p .explanation>
+      _{MsgAllocationNotificationNewCourseTip}
+      <br>
+      _{bool MsgAllocationNotificationNewCourseCurrentlyOff MsgAllocationNotificationNewCourseCurrentlyOn wouldNotifyNewCourse}
+    ^{notificationForm'}
+  $else
+    _{MsgAllocationNotificationLoginFirst}
+
 $if not (null courseWidgets)
   <section .allocation>
     <h2>

templates/changelog.hamlet

@@ -0,0 +1,14 @@
+$newline never
+<dl .deflist #changelog>
+  $forall (Down d, es) <- Map.toList changelogEntries
+    <dt .deflist__dt ##{"changelog-date--" <> toPathPiece d}>
+      ^{formatTimeW SelFormatDate d}
+    <dd .deflist__dd>
+      <ul>
+        $forall e <- Set.toList es
+          <li ##{"changelog-item--" <> toPathPiece e}>
+            $if is _ChangelogItemBugfix $ classifyChangelogItem e
+              <i>
+                _{ChangelogItemBugfix}
+                : #
+            ^{changelogItems ! toPathPiece e}

templates/exam-show.hamlet

@@ -20,6 +20,9 @@ $maybe desc <- examDescription
     #{desc}
 
 <section>
+  $maybe warn <- notificationDiscouragedExamMode
+    ^{warn}
+  
   <dl .deflist>
     $if not examVisible
       <dt .deflist__dt>_{MsgExamVisibleFrom}
@@ -41,6 +44,41 @@ $maybe desc <- examDescription
     $maybe publishAssignments <- examPublishOccurrenceAssignments
       <dt .deflist__dt>_{MsgExamPublishOccurrenceAssignmentsParticipant}
       <dd .deflist__dd>^{formatTimeW SelFormatDateTime publishAssignments}
+    $maybe online <- examOnline examExamMode
+      <dt .deflist__dt>_{MsgExamShowOnline}
+      <dd .deflist__dd>
+        $case online
+          $of ExamOnlinePreset p 
+            ^{examOnlinePresetWidget p}
+          $of ExamOnlineCustom c
+            #{c}
+    $maybe synchronicity <- examSynchronicity examExamMode
+      <dt .deflist__dt>_{MsgExamShowSynchronicity}
+      <dd .deflist__dd>
+        $case synchronicity
+          $of ExamSynchronicityPreset p 
+            ^{examSynchronicityPresetWidget p}
+          $of ExamSynchronicityCustom c
+            #{c}
+    $maybe aids <- examAids examExamMode
+      <dt .deflist__dt>_{MsgExamShowAids}
+      <dd .deflist__dd>
+        $case aids
+          $of ExamAidsPreset p 
+            ^{examAidsPresetWidget p}
+          $of ExamAidsCustom c
+            #{c}
+    $maybe requiredEquipment <- examRequiredEquipment examExamMode
+      <dt .deflist__dt>_{MsgExamShowRequiredEquipment}
+      <dd .deflist__dd>
+        <p>
+          $case requiredEquipment
+            $of ExamRequiredEquipmentPreset p 
+              ^{examRequiredEquipmentPresetWidget p}
+            $of ExamRequiredEquipmentCustom c
+              #{c}
+
+        ^{notificationPersonalIdentification}
     $maybe room <- examRoom
       <dt .deflist__dt>_{MsgExamRoom}
       <dd .deflist__dd>#{room}
@@ -89,6 +127,8 @@ $maybe desc <- examDescription
         _{MsgExamRegistration}
       <dd .deflist__dd>
         ^{registerWdgt}
+  $if is _Nothing (examRequiredEquipment examExamMode)
+    ^{notificationPersonalIdentification}
 
 $if showCloseWidget && is _Nothing examClosed
   <section>

templates/i18n/changelog/abolish-course-associated-study-features.de-de-formal.hamlet

@@ -0,0 +1,4 @@
+$newline never
+Kursassoziierte Studienfächer wurden abgeschafft.
+<br>
+Es werden nun an allen kursbezogenen Stellen jene Studiendaten angezeigt, die während des entsprechenden Semesters aktuell waren.

templates/i18n/changelog/abolish-course-associated-study-features.en-eu.hamlet

@@ -0,0 +1,4 @@
+$newline never
+Abolished course-associated features of study.
+<br>
+In course-related contexts now all study features which were up to date during the relevant term are displayed.

templates/i18n/changelog/account-deletion-during-testing.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Benutzer können sich in der Testphase komplett selbst löschen

templates/i18n/changelog/account-deletion-during-testing.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+During testing users may completely delete their accounts

templates/i18n/changelog/additional-datetime-formats.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Zusätzliche Uhrzeit- und Datumsformate

templates/i18n/changelog/additional-datetime-formats.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Additional date and time formats

templates/i18n/changelog/additional-sheet-notifications.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Zusätzliche Benachrichtigungen für Übungsblätter

templates/i18n/changelog/additional-sheet-notifications.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Additional notifications for exercise sheets

templates/i18n/changelog/allocation-applications.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Bewerbungen für Zentralanmeldungen

templates/i18n/changelog/allocation-applications.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Applications for central allocations

templates/i18n/changelog/allocation-course-registration.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Kurse zu Zentralanmeldungen eintragen

templates/i18n/changelog/allocation-course-registration.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Registration of courses for central allocation

templates/i18n/changelog/allocation-new-course-notification.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Benachrichtigungen, wenn neue Kurse zu Zentralanmeldungen hinzugefügt werden

templates/i18n/changelog/allocation-new-course-notification.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Notifications for new courses being added to central allocations

templates/i18n/changelog/allocations-notifications.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Benachrichtigungen für Zentralanmeldungen

templates/i18n/changelog/allocations-notifications.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Notifications for central allocations

templates/i18n/changelog/asidenav.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Designänderungen

templates/i18n/changelog/asidenav.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Design changes

templates/i18n/changelog/assigned-corrections-filters.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Liste zugewiesener Abgaben lassen sich nun filtern

templates/i18n/changelog/assigned-corrections-filters.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Filters for list of assigned corrections

templates/i18n/changelog/automatically-accept-course-applications.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Automatische Anmeldung von Bewerbern in Kursen, die nicht an einer Zentralanmeldung teilnehmen (nach Bewertung der Bewerbung)

templates/i18n/changelog/automatically-accept-course-applications.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Option to automatically accept applications for courses outside of central allocations

templates/i18n/changelog/better-course-communication-tutorials.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Besseres Verschicken von Kursmitteilungen an Tutoriumsteilnehmer

templates/i18n/changelog/better-course-communication-tutorials.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Better sending of course communications to tutorial participants

templates/i18n/changelog/better-course-participant-detail-page.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Anzeige von Abgaben, Tutorien und Klausuren auf der Seite für einzelne Kursteilnehmer

templates/i18n/changelog/better-course-participant-detail-page.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Submissions, tutorials, and exams are now shown on the detail page for course participants

templates/i18n/changelog/better-csv-import.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Verbesserter Workflow & Fehlerbehandlung für CSV-Import

templates/i18n/changelog/better-csv-import.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Improved workflow and error-handling for CSV-import

templates/i18n/changelog/better-file-uploads.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Verbesserte Handhabung von Datei-Uploads

templates/i18n/changelog/better-file-uploads.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Improved handling of file uploads

templates/i18n/changelog/better-table-cell-colour-coding.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Verbesserte Farbkodierung von Tabellenzellen

templates/i18n/changelog/better-table-cell-colour-coding.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Improved colour coding of table cells

templates/i18n/changelog/buttons-work-without-javascript.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript

templates/i18n/changelog/buttons-work-without-javascript.en-eu.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Multiple buttons/forms no work again when JavaScript is enabled

templates/i18n/changelog/configurable-datetime-format.de-de-formal.hamlet

@@ -0,0 +1,2 @@
+$newline never
+Wählbares Format für Datum