Merge branch 'master' into course-teaser

CHANGELOG.md

@@ -2,6 +2,152 @@
 
 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.
 
+### [4.12.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.12.0...v4.12.1) (2019-08-06)
+
+
+### Bug Fixes
+
+* **exams:** allow occurrences after exam end ([3d63b35](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3d63b35))
+
+
+
+## [4.12.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.11.0...v4.12.0) (2019-08-06)
+
+
+### Features
+
+* **exams:** improve immediate exam table on home page ([93e718f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/93e718f))
+
+
+
+## [4.11.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.10.0...v4.11.0) (2019-08-06)
+
+
+### Bug Fixes
+
+* **course-edit:** additional permission checks wrt allocations ([fca5caa](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fca5caa))
+
+
+### Features
+
+* **audit:** automatic transaction log truncation ([248482b](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/248482b))
+* **audit:** introduce id-based format ([f602b79](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f602b79))
+* **audit:** take IP from header ([fb027de](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/fb027de))
+* **exams:** show occurrenceRule in exam overview ([06673e0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/06673e0))
+
+
+
+## [4.10.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.9.0...v4.10.0) (2019-08-05)
+
+
+### Bug Fixes
+
+* **jobs:** only write CronLastExec after job has executed ([67eda82](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/67eda82))
+
+
+### Features
+
+* **notifications:** add NotificationExamResult ([a7e2921](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a7e2921))
+
+
+
+## [4.9.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.8.0...v4.9.0) (2019-08-05)
+
+
+### Features
+
+* **allocations:** add courses to allocations ([14a9a45](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/14a9a45))
+* **allocations:** create model for allocations ([82e3bf9](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/82e3bf9))
+* **allocations:** prevent course (de)registrations ([94a1208](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/94a1208))
+* **allocations:** refine model for allocations ([069eb1e](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/069eb1e))
+* **csv-import:** automagically determine csv delimiters ([3555322](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/3555322))
+
+
+
+## [4.8.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.7.0...v4.8.0) (2019-07-31)
+
+
+### Bug Fixes
+
+* **exam add users:** correctly differentiate and fix messages ([a473599](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a473599))
+
+
+### Features
+
+* **exams:** better explain "enlist directly" ([f07eb3d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/f07eb3d))
+
+
+
+## [4.7.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.6.0...v4.7.0) (2019-07-30)
+
+
+### Features
+
+* **exam users:** course notes ([1e756be](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/1e756be))
+* **notification triggers:** redesign interface ([84c12b5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/84c12b5)), closes [#410](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/410)
+* **users:** lecturer invitations ([e6c3be4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e6c3be4))
+* **users:** switching between AuthModes & password changing ([0d610cc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d610cc))
+
+
+
+## [4.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.5.0...v4.6.0) (2019-07-26)
+
+
+### Features
+
+* **exam-users:** allow missing columns in csv import ([e242013](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e242013))
+
+
+
+## [4.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.4.0...v4.5.0) (2019-07-26)
+
+
+### Bug Fixes
+
+* fix merge ([38afa90](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/38afa90))
+* **csv-import:** fix incorrect map merge ([0d283fd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d283fd))
+* **dbtable-ui:** fix position of submit button for pagesize ([cf35118](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf35118))
+* **merge:** fix build ([0bd0260](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bd0260))
+
+
+### Features
+
+* **alert-icons:** add custom icons for alerts ([bc67500](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/bc67500))
+* **alerticons:** allow alerts to have custom icons ([d70a958](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d70a958))
+* **alerts js:** support custom icons in Alerts HTTP-Header ([8833cb5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8833cb5))
+* **corrections assignment:** add convenience to table header ([56c2fcc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56c2fcc))
+* **course enrolement:** show proper icons in alerts ([b2b3895](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b2b3895))
+* **exam-users:** provide better table defaults ([a689d19](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a689d19))
+* **exams:** csv-based grade upload ([932145c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/932145c))
+* **exams:** show exam results ([b8b308d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b8b308d))
+* **users:** store first names and titles ([ceed070](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ceed070))
+
+
+
+## [4.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.3.0...v4.4.0) (2019-07-24)
+
+
+### Bug Fixes
+
+* **exam-csv:** audit registrations/deregistrations ([a278cc5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a278cc5))
+* **js:** fix i18n not loading ([a3ee6f6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a3ee6f6))
+
+
+### Features
+
+* **exams:** implement exam registration invitations ([dd90fd0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/dd90fd0))
+
+
+
+## [4.3.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.2.0...v4.3.0) (2019-07-24)
+
+
+### Features
+
+* **health:** check for active job workers ([d1abe53](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d1abe53))
+
+
+
 ## [4.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.1.2...v4.2.0) (2019-07-23)
 
 

config/settings.yml

@@ -36,8 +36,10 @@ health-check-interval:
   ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
   smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
   widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
+  active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
 health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
 health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
+health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
 
 log-settings:
   detailed:      "_env:DETAILED_LOGGING:false"
@@ -45,6 +47,8 @@ log-settings:
   minimum-level: "_env:LOGLEVEL:warn"
   destination:   "_env:LOGDEST:stderr"
 
+ip-retention-time: 1209600
+
 # Debugging
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"

default.nix

@@ -1,6 +1,6 @@
 argumentPackages@{ ... }:
 
 let
-  defaultPackages = (import <nixpkgs> {}).haskellPackages;
+  defaultPackages = (import ./stackage.nix {});
   haskellPackages = defaultPackages // argumentPackages;
 in import ./uniworx.nix { inherit (haskellPackages) callPackage; }

frontend/src/utils/alerts/alerts.js

@@ -16,6 +16,11 @@ const ALERT_INVISIBLE_CLASS = 'alert--invisible';
 const ALERT_AUTO_HIDE_DELAY = 10;
 const ALERT_AUTOCLOSING_MATCHER = '.alert-info, .alert-success';
 
+/*
+ * Dataset-Inputs:
+ *  - decay (data-decay): Custom time (in seconds) for this alert to stay visible
+ */
+
 @Utility({
   selector: '[uw-alerts]',
 })
@@ -132,7 +137,7 @@ export class Alerts {
 
     if (alerts) {
       alerts.forEach((alert) => {
-        const alertElement = this._createAlertElement(alert.status, alert.content);
+        const alertElement = this._createAlertElement(alert.status, alert.content, alert.icon === null ? undefined : alert.icon);
         this._element.appendChild(alertElement);
         this._alertElements.push(alertElement);
         this._initAlert(alertElement);
@@ -142,7 +147,7 @@ export class Alerts {
     }
   }
 
-  _createAlertElement(type, content) {
+  _createAlertElement(type, content, icon = 'info-circle') {
     const alertElement = document.createElement('div');
     alertElement.classList.add(ALERT_CLASS, 'alert-' + type);
 
@@ -150,7 +155,7 @@ export class Alerts {
     alertCloser.classList.add(ALERT_CLOSER_CLASS);
 
     const alertIcon = document.createElement('div');
-    alertIcon.classList.add(ALERT_ICON_CLASS);
+    alertIcon.classList.add(ALERT_ICON_CLASS, 'fas', 'fa-fw', 'fa-' + icon);
 
     const alertContent = document.createElement('div');
     alertContent.classList.add(ALERT_CONTENT_CLASS);

frontend/src/utils/alerts/alerts.scss

@@ -32,6 +32,10 @@
     font-size: 30px;
     transform: translateX(-50%);
   }
+
+  &:hover::before {
+    color: var(--color-grey-medium);
+  }
 }
 
 .alerts--elevated {
@@ -68,6 +72,10 @@
 
 .alert a {
   color: var(--color-lightwhite);
+
+  &:hover {
+    color: var(--color-grey);
+  }
 }
 
 @keyframes slide-in-alert {
@@ -124,9 +132,9 @@
   z-index: 40;
 
   &::before {
-    content: '\f05a';
+    /* content: var(--alert-icon, var(--alert-icon-default, '\f05a')); */
     position: absolute;
-    font-family: 'Font Awesome 5 Free';
+    /* font-family: 'Font Awesome 5 Free'; */
     font-size: 24px;
     top: 50%;
     left: 50%;
@@ -188,23 +196,26 @@
 .alert-success {
   background-color: var(--color-success);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f058';
+   *   --alert-icon-default: '\f058';
-  }
+   * }
+   */
 }
 
 .alert-warning {
   background-color: var(--color-warning);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f06a';
+   *   --alert-icon-default: '\f06a';
-  }
+   * }
+   */
 }
 
 .alert-error {
   background-color: var(--color-error);
 
-  .alert__icon::before {
+  /* .alert__icon::before {
-    content: '\f071';
+   *   --alert-icon-default: '\f071';
-  }
+   * }
+   */
 }

frontend/src/utils/form/interactive-fieldset.js

@@ -28,6 +28,10 @@ export class InteractiveFieldset {
       return false;
     }
 
+    if (this._element.querySelector('[uw-interactive-fieldset]')) {
+      return false;
+    }
+
     // param conditionalInput
     if (!this._element.dataset.conditionalInput) {
       throw new Error('Interactive Fieldset needs a selector for a conditional input!');

is-clean.sh

@@ -0,0 +1,21 @@
+#!/usr/bin/env bash
+
+set -e
+
+if [ -n "$(git status --porcelain)" ]; then
+    echo "Working directory isn't clean" >&2
+    exit 1
+fi
+
+if [ "$(git rev-parse --abbrev-ref HEAD)" != "master" ]; then
+    echo "Not on master" >&2
+    exit 1
+fi
+
+ourHash=$(git rev-parse HEAD)
+theirHash=$(git ls-remote origin -h refs/heads/master | awk '{ print $1; }')
+
+if [ "$theirHash" != "$ourHash" ]; then
+    echo "Local HEAD is not up to date with remote master" >&2
+    exit 1
+fi

messages/uniworx/de.msg

@@ -142,6 +142,28 @@ CourseUserSendMail: Mitteilung verschicken
 TutorialUserDeregister: Vom Tutorium Abmelden
 TutorialUserSendMail: Mitteilung verschicken
 TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet
+CourseAllocationParticipate: Teilnahme an Zentralanmeldung
+CourseAllocationParticipateTip: Wird an einer Zentralanmeldung teilgenommen, kann es sein, dass Sie bestimmte Rechte, die Sie normalerweise bzgl. Ihres Kurses hätten, nicht ausüben können (z.B. Studenten direkt zum Kurs anmelden, Studenten abmelden, ...).
+CourseAllocation: Zentralanmeldung
+CourseAllocationOption term@Text name@Text: #{name} (#{term})
+CourseAllocationMinCapacity: Minimale Teilnehmeranzahl
+CourseAllocationMinCapacityTip: Wenn der Veranstaltung bei der Zentralanmeldung weniger als diese Anzahl von Teilnehmern zugeteilt würden, werden diese stattdessen auf andere Kurse umverteilt
+CourseAllocationMinCapacityMustBeNonNegative: Minimale Teilnehmeranzahl darf nicht negativ sein
+CourseAllocationInstructions: Anweisungen zur Bewerbung
+CourseAllocationInstructionsTip: Wird den Studierenden angezeigt, wenn diese sich für Ihre Veranstaltung bewerben
+CourseAllocationApplicationTemplate: Bewerbungsvorlagen
+CourseAllocationApplicationText: Text-Bewerbungen
+CourseAllocationApplicationTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
+CourseAllocationApplicationRatingsVisible: Feedback für Bewerbungen
+CourseAllocationApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
+
+
+CourseNoAllocationsAvailable: Es sind aktuell keine Zentralanmeldungen verfügbar
+AllocationStaffRegisterToExpired: Es dürfen keine Änderungen an der Eintragung des Kurses zur Zentralanmeldung mehr vorgenommen werden
+
+
+CourseFormSectionRegistration: Anmeldung
+CourseFormSectionAdministration: Verwaltung
 
 CourseLecturers: Kursverwalter
 CourseLecturer: Dozent
@@ -150,6 +172,10 @@ CourseLecturerAlreadyAdded email@UserEmail: Es gibt bereits einen Kursverwalter
 CourseRegistrationEndMustBeAfterStart: Ende des Anmeldezeitraums muss nach dem Anfang liegen
 CourseDeregistrationEndMustBeAfterStart: Ende des Abmeldezeitraums muss nach dem Anfang des Anmeldezeitraums liegen
 CourseUserMustBeLecturer: Aktueller Benutzer muss als Kursverwalter eingetragen sein
+CourseAllocationRequiresCapacity: Bei Teilnahme an einer Zentralanmeldung muss eine Kurskapazität angegeben werden
+CourseAllocationTermMustMatch: Kurs-Semester muss mit Semester der Zentralanmeldung übereinstimmen
+CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Zentralanmeldung teilnimmt, darf nicht nachträglich verändert werden
+
 CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
 
 NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht.
@@ -314,6 +340,14 @@ UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium.
 UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs.
 UnauthorizedTutor: Sie sind nicht Tutor.
 UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe.
+UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an.
+UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an.
+
+UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden
+
+UnauthorizedAllocatedCourseRegister: Direkte Anmeldungen zum Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
+UnauthorizedAllocatedCourseDeregister: Abmeldungen vom Kurs sind aufgrund einer Zentralanmeldung aktuell nicht gestattet
+UnauthorizedAllocatedCourseDelete: Kurse, die an einer Zentralanmeldung teilnehmen, dürfen nicht gelöscht werden
 
 EMail: E-Mail
 EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@@ -504,7 +538,9 @@ NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Klausur mit offener Reg
 
 AdminHeading: Administration
 AdminUserHeading: Benutzeradministration
-AccessRightsFor: Berechtigungen für
+AdminUserRightsHeading: Benutzerrechte
+AdminUserAuthHeading: Benutzer-Authentifizierung
+AdminUserHeadingFor: Benuterprofil für
 AdminFor: Administrator
 LecturerFor: Dozent
 LecturersFor: Dozenten
@@ -551,6 +587,16 @@ PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team sp
 DummyLoginTitle: Development-Login
 LoginNecessary: Bitte melden Sie sich dazu vorher an!
 
+InternalLdapError: Interner Fehler beim Campus-Login
+
+CampusUserInvalidEmail: Konnte anhand des Campus-Logins keine EMail-Addresse ermitteln
+CampusUserInvalidDisplayName: Konnte anhand des Campus-Logins keinen vollen Namen ermitteln
+CampusUserInvalidGivenName: Konnte anhand des Campus-Logins keinen Vornamen ermitteln
+CampusUserInvalidSurname: Konnte anhand des Campus-Logins keinen Nachname ermitteln
+CampusUserInvalidTitle: Konnte anhand des Campus-Logins keinen akademischen Titel ermitteln
+CampusUserInvalidMatriculation: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln
+CampusUserInvalidFeaturesOfStudy parseErr@String: Konnte anhand des Campus-Logins keine Matrikelnummer ermitteln: #{parseErr}
+
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
@@ -639,6 +685,9 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
 MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
 MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
 
+MailSubjectExamResult csh@CourseShorthand examn@ExamName: Ergebnisse für #{examn} in #{csh} wurden herausgegeben
+MailExamResultIntro courseName@Text termDesc@Text examn@ExamName: Sie können nun Ihr Ergebnis für #{examn} im Kurs #{courseName} (#{termDesc}) einsehen.
+
 MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
 MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
 
@@ -655,6 +704,13 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U
 MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte.
 MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen.
 
+MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus
+UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an
+UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an
+NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen:
+NewPasswordLink: Neues Passwort setzen
+AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
+PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
 
 MailEditNotifications: Benachrichtigungen ein-/ausschalten
 MailSubjectSupport: Supportanfrage
@@ -672,8 +728,12 @@ MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@Tuto
 
 MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{examn}
 
+MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Teilnehmer für #{examn}
+
 MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
 
+MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
+
 SheetGrading: Bewertung
 SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte
 SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten
@@ -722,6 +782,15 @@ NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter is
 NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
 NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden
 NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
+NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert
+NotificationTriggerExamResult: Ich kann ein neues Klausurergebnis einsehen
+
+NotificationTriggerKindAll: Für alle Benutzer
+NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
+NotificationTriggerKindExamParticipant: Für Klausurteilnehmer
+NotificationTriggerKindCorrector: Für Korrektoren
+NotificationTriggerKindLecturer: Für Dozenten
+NotificationTriggerKindAdmin: Für Administratoren
 
 CorrCreate: Abgaben erstellen
 UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@@ -838,6 +907,7 @@ MenuTermShow: Semester
 MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
 MenuUserNotifications: Benachrichtigungs-Einstellungen
+MenuUserPassword: Passwort
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
 MenuAdminErrMsg: Fehlermeldung entschlüsseln
@@ -883,6 +953,8 @@ MenuExamList: Klausuren
 MenuExamNew: Neue Klausur anlegen
 MenuExamEdit: Bearbeiten
 MenuExamUsers: Teilnehmer
+MenuExamAddMembers: Klausurteilnehmer hinzufügen
+MenuLecturerInvite: Dozenten hinzufügen
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -897,6 +969,7 @@ AuthTagLecturer: Nutzer ist Dozent
 AuthTagCorrector: Nutzer ist Korrektor
 AuthTagTutor: Nutzer ist Tutor
 AuthTagTime: Zeitliche Einschränkungen sind erfüllt
+AuthTagAllocationTime: Zeitliche Einschränkungen durch Zentralanmeldung sind erfüllt
 AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
 AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
 AuthTagExamRegistered: Nutzer ist Klausurteilnehmer
@@ -910,6 +983,8 @@ AuthTagRated: Korrektur ist bewertet
 AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
 AuthTagSelf: Nutzer greift nur auf eigene Daten zu
+AuthTagIsLDAP: Nutzer meldet sich mit Campus-Kennung an
+AuthTagIsPWHash: Nutzer meldet sich mit Uni2work-Kennung an
 AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend
@@ -957,7 +1032,7 @@ CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu
 
 CourseParticipantInviteHeading courseName@Text: Einladung zum Kursteilnahmer für #{courseName}
 CourseParticipantInviteExplanation: Sie wurden eingeladen, an einem Kurs teilzunehmen.
-CourseParticipantEnlistDirectly: Bekannte Teilnehmer sofort als Teilnehmer eintragen
+CourseParticipantEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
 CourseParticipantInviteField: Einzuladende EMail Adressen
 
 CourseParticipantInvitationAccepted courseName@Text: Sie wurden als Teilnehmer für #{courseName} eingetragen
@@ -974,10 +1049,15 @@ TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
 TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
 
 ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für #{examn} eingetragen
-ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für  #{examn} zu werden, abgelehnt
+ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt
 ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für #{examn}
 ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein.
 
+ExamRegistrationInvitationAccepted examn@ExamName: Sie wurden als Teilnehmer für #{examn} eingetragen
+ExamRegistrationInvitationDeclined examn@ExamName: Sie haben die Einladung, Teilnehmer für #{examn} zu werden, abgelehnt
+ExamRegistrationInviteHeading examn@ExamName: Einladung zum Teilnehmer für #{examn}
+ExamRegistrationInviteExplanation: Sie wurden eingeladen, Klausurteilnehmer zu sein.
+
 SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen
 SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt
 SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn}
@@ -1065,6 +1145,7 @@ HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werd
 HealthLDAPAdmins: Anteil der Administratoren, die im LDAP-Verzeichnis gefunden werden können
 HealthSMTPConnect: SMTP-Server kann erreicht werden
 HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus
+HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen
 
 CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer
 CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
@@ -1073,6 +1154,19 @@ CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wu
 CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet
 CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen
 
+ExamRegistrationAndCourseParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zum Kurs, als auch zur Klausur angemeldet
+ExamRegistrationNotRegisteredWithoutCourse n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} nicht zur Klausur angemeldet, da #{pluralDE n "er" "sie"} nicht zum Kurs angemeldet #{pluralDE n "ist" "sind"}
+ExamRegistrationRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} sowohl zur Klausur, als auch #{pluralDE n "ohne assoziiertes Hauptfach" "ohne assoziierte Hauptfächer"} zum Kurs angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"}
+ExamRegistrationParticipantsRegistered n@Int: #{n} Teilnehmer #{pluralDE n "wurde" "wurden"} zur Klausur angemeldet
+ExamRegistrationInviteDeadline: Einladung nur gültig bis
+ExamRegistrationEnlistDirectly: Bekannte Nutzer sofort als Teilnehmer eintragen
+ExamRegistrationEnlistDirectlyTip: Sollen, wenn manche der E-Mail Addressen bereits in Uni2work mit Nutzern assoziiert sind, jene Nutzer direkt zur Klausur hinzugefügt werden? Ansonsten werden Einladung an alle E-Mail Addressen (nicht nur unbekannte) versandt, die die Nutzer zunächst akzeptieren müssen um Klausurteilnehmer zu werden.
+ExamRegistrationRegisterCourse: Nutzer auch zum Kurs anmelden
+ExamRegistrationRegisterCourseTip: Nutzer, die keine Kursteilnehmer sind, werden sonst nicht zur Klausur angemeldet.
+ExamRegistrationInviteField: Einzuladende EMail Addressen
+ExamParticipantsRegisterHeading: Klausurteilnehmer hinzufügen
+ExamParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt
+
 ExamName: Name
 ExamTime: Termin
 ExamsHeading: Klausuren
@@ -1119,7 +1213,7 @@ ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer
 ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen
 
 ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung
-ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilung
+ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren
 ExamRoomManual': Keine automatische Zuteilung
 ExamRoomSurname': Nach Nachname
 ExamRoomMatriculation': Nach Matrikelnummer
@@ -1222,8 +1316,9 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p
 
 CsvColumnsExplanationsLabel: Spalten
 CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten
-CsvColumnExamUserSurname: Nachname des Teilnehmers
+CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
-CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname)
+CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
+CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
 CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers
 CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
 CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt
@@ -1233,19 +1328,25 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
 CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können
 CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
 CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können
+CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
+CsvColumnExamUserCourseNote: Notizen zum Teilnehmer
 
 Action: Aktion
 
 DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen Datensatz und können daher nicht verarbeitet werden.
 DBCsvDuplicateKeyTip: Entfernen Sie eine der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut.
 DBCsvKeyException: Für eine Zeile der CSV-Dateien konnte nicht festgestellt werden, ob sie zu einem bestehenden internen Datensatz korrespondieren.
-DBCsvException: Bei der Berechnung der auszuführenden Aktionen für einen Datensatz ist ein Fehler aufgetreten. 
+DBCsvException: Bei der Berechnung der auszuführenden Aktionen für einen Datensatz ist ein Fehler aufgetreten.
 
 ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Klausur anmelden
 ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden
 ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
 ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden
 ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern
+ExamUserCsvSetResult: Ergebnis eintragen
+ExamUserCsvSetCourseNote: Teilnehmer-Notizen anpassen
+
+ExamUserCsvCourseNoteDeleted: Notiz wird gelöscht
 
 ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
 ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden
@@ -1253,4 +1354,47 @@ ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig ide
 
 TableHeadingFilter: Filter
 TableHeadingCsvImport: CSV-Import
-TableHeadingCsvExport: CSV-Export
+TableHeadingCsvExport: CSV-Export
+
+ExamResultAttended: Teilgenommen
+ExamResultNoShow: Nicht erschienen
+ExamResultVoided: Entwertet
+ExamResultNone: Kein Klausurergebnis
+
+BtnAuthLDAP: Auf Campus-Kennung umstellen
+BtnAuthPWHash: Auf Uni2work-Kennung umstellen
+BtnPasswordReset: Passwort zurücksetzen
+
+AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden
+AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden
+AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an
+AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an
+
+AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an
+AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an
+
+PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt
+ResetPassword: Uni2work-Passwort ändern bzw. setzen
+
+AuthMode: Authentifizierung
+AuthLDAP: Campus
+AuthPWHash pwHash@Text: Uni2work
+CurrentPassword: Aktuelles Passwort
+NewPassword: Neues Passwort
+NewPasswordRepeat: Wiederholung
+CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt
+PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
+UserPasswordHeadingFor: Passwort ändern für
+PasswordChangedSuccess: Passwort erfolgreich geändert
+
+LecturerInviteSchool: Institut
+LecturerInviteField: Einzuladende EMail Addressen
+LecturerInviteHeading: Dozenten hinzufügen
+
+LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen
+LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen
+
+MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“
+MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“
+SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
+SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen

models/allocations

@@ -0,0 +1,71 @@
+Allocation -- attributes with prefix staff- affect lecturers only, but are invisble to students
+    name                (CI Text)
+    shorthand           (CI Text)       -- practical shorthand
+    term                TermId
+    school              SchoolId        -- school that manages this central allocation, not necessarily school of courses
+    description         Html Maybe      -- description for prospective students
+    staffDescription    Html Maybe      -- description seen by prospective lecturers only
+    linkExternal        Text Maybe      -- arbitrary user-defined url for external course page
+    capacity            Int Maybe       -- number of allowed enrolements, if restricte
+    staffRegisterFrom   UTCTime Maybe   -- lectureres may register courses
+    staffRegisterTo     UTCTime Maybe   -- course registration stops
+    -- staffDeregisterUntil not needed: staff may make arbitrary changes until staffRegisterTo, always frozen afterwards
+    staffAllocationFrom UTCTime Maybe   -- lecturers may rate applicants from this day onwwards or prohibited
+    staffAllocationTo   UTCTime Maybe   --
+    -- Student register for this allocation
+    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+    registerFrom        UTCTime Maybe   -- student applications allowed from a given day onwwards or prohibited
+    registerTo          UTCTime Maybe   -- student applications may be prohibited from a given date onwards
+    -- deregisterUntil not needed: students may withdraw applicants until registerTo, but never after. Also see overrideDeregister
+    registerSecret      Text Maybe      -- student application maybe protected by a simple common passphrase
+    -- overrides
+    registerByStaffFrom UTCTime Maybe   -- lecturers may directly enrol/disenrol students after a given date or prohibited
+    registerByStaffTo   UTCTime Maybe
+    registerByCourse    UTCTime Maybe   -- course registration dates are ignored until this day has passed or always prohibited
+    overrideDeregister  UTCTime Maybe   -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
+    -- overrideVisible not needed, since courses are always visible
+    TermSchoolAllocationShort  term school shorthand    -- shorthand must be unique within school and semester
+    TermSchoolAllocationName   term school name         -- name must be unique within school and semester
+
+AllocationCourse
+    allocation          AllocationId
+    course              CourseId
+    minCapacity         Int          -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course
+    instructions        Html Maybe   -- instructions from the lecturer to applicants
+    applicationText     Bool         -- lecturer will read application texts supplied by users
+    applicationFiles    UploadMode   -- lecturer wants to receive course specific application files
+    ratingsVisible      Bool         -- lecturer wants applicants to receive feedback on their application (Grade & comment)
+    UniqueAllocationCourse course
+
+AllocationCourseFile
+    allocationCourse    AllocationCourseId
+    file                FileId
+    UniqueAllocationCourseFile allocationCourse file
+
+AllocationUser
+    allocation          AllocationId
+    user                UserId
+    totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number
+    UniqueAllocationUser allocation user
+
+AllocationApplication
+    allocationCourse    AllocationCourseId
+    allocationUser      AllocationUserId
+    text                Text       Maybe -- free text entered by user
+    priority            Natural          -- priority, higher number means higher priority
+    ratingVeto          Bool
+    ratingPoints        ExamGrade Maybe
+    ratingComment       Text      Maybe
+    UniqueAllocationApplication allocationCourse allocationUser
+
+AllocationApplicationFile -- supplemental file for application by a user for a certain course
+    application          AllocationApplicationId
+    file                 FileId
+    UniqueAllocationUserFile application file
+
+AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
+    user                UserId
+    allocation          AllocationId Maybe
+    course              CourseId Maybe
+    time                UTCTime
+    reason              Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)

models/audit

@@ -2,11 +2,6 @@
 TransactionLog
   time UTCTime
   instance InstanceId
-  initiator UserIdent Maybe -- Case-insensitive user-identifier associated with performing this action
+  initiator UserId Maybe -- User associated with performing this action
   remote IP Maybe -- Remote party that triggered this action via HTTP
-  info Value -- JSON-encoded `Transaction`
+  info Value -- JSON-encoded `Transaction`
--- Best guess of users affected by a change in database-state at time of transaction
-TransactionLogAffected
-  transaction TransactionLogId
-  user UserIdent -- Case-insensitive user-identifier
-  UniqueTransactionLogAffected transaction user

models/courses

@@ -40,6 +40,7 @@ CourseParticipant                      -- course enrolement
     user         UserId
     registration UTCTime               -- time of last enrolement for this course
     field        StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
+    allocated    Bool default=false    -- participant was centrally allocated
     UniqueParticipant user course
 -- Replace the last two by the following, once an audit log is available
 -- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student

models/exams

@@ -47,6 +47,7 @@ ExamResult
   exam ExamId
   user UserId
   result ExamResultGrade
+  lastChanged UTCTime default=now()
   UniqueExamResult exam user
 ExamCorrector
   exam ExamId

models/jobs

@@ -5,6 +5,7 @@ QueuedJob
     creationTime        UTCTime
     lockInstance        InstanceId Maybe   -- instance that has started to execute this job
     lockTime            UTCTime Maybe      -- time when execution had begun
+    writeLastExec       Bool default=false -- record successful execution to CronLastExec
     deriving Eq Read Show Generic Typeable
 
 -- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@

models/users

@@ -16,6 +16,8 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     email          (CI Text)                -- Case-insensitive eMail address
     displayName    Text                     -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
     surname        Text                     -- Display user names always through 'nameWidget displayName surname'
+    firstName      Text                     -- For export in tables, pre-split firstName from displayName
+    title          Text Maybe               -- For upcoming name customisation
     maxFavourites  Int default=12           -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
     theme          Theme default='Default'  -- Color-theme of the frontend; user-defined
     dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined

nixpkgs.nix

@@ -0,0 +1,9 @@
+{ nixpkgs ? import <nixpkgs>
+}:
+
+import ((nixpkgs {}).fetchFromGitHub {
+  owner = "NixOS";
+  repo = "nixpkgs";
+  rev = "19.03";
+  sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy";
+})

package-lock.json

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

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "4.2.0",
+  "version": "4.12.1",
   "description": "",
   "keywords": [],
   "author": "",
@@ -20,7 +20,7 @@
     "frontend:test:watch": "karma start --conf karma.conf.js --single-run false",
     "frontend:build": "webpack",
     "frontend:build:watch": "webpack --watch",
-    "prerelease": "npm run test",
+    "prerelease": "./is-clean.sh && npm run test",
     "release": "standard-version -a",
     "postrelease": "git push --follow-tags origin master"
   },

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 4.2.0
+version: 4.12.1
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage
@@ -75,6 +75,7 @@ dependencies:
   - blaze-html
   - conduit-resumablesink >=0.2
   - parsec
+  - attoparsec
   - uuid
   - exceptions
   - stm
@@ -133,6 +134,7 @@ dependencies:
   - cassava
   - cassava-conduit
   - constraints
+  - memory
 
 other-extensions:
   - GeneralizedNewtypeDeriving

routes

@@ -24,6 +24,9 @@
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
+--    !is-ldap        -- user has authentication mode set to LDAP
+--    !is-pw-hash     -- user has authentication mode set to PWHash
+--
 --    !materials      -- only if course allows all materials to be free (no meaning outside of courses)
 --    !time           -- access depends on time somehow
 --    !read           -- only if it is read-only access (i.e. GET but not POST)
@@ -45,6 +48,9 @@
 /users/#CryptoUUIDUser/delete AdminUserDeleteR     POST
 /users/#CryptoUUIDUser/hijack AdminHijackUserR     POST       !adminANDno-escalation
 /users/#CryptoUUIDUser/notifications UserNotificationR GET POST   !self
+/users/#CryptoUUIDUser/password      UserPasswordR     GET POST   !selfANDis-pw-hash
+!/users/lecturer-invite/new    AdminNewLecturerInviteR  GET POST
+!/users/lecturer-invite        AdminLecturerInviteR     GET POST
 /admin                        AdminR           GET
 /admin/features               AdminFeaturesR   GET POST
 /admin/test                   AdminTestR       GET POST
@@ -80,12 +86,12 @@
 !/course/new                CourseNewR         GET POST        !lecturer
 /course/#TermId/#SchoolId/#CourseShorthand CourseR             !lecturer:
   /                           CShowR           GET             !free
-  /register                   CRegisterR       GET POST        !timeANDcapacity
+  /register                   CRegisterR       GET POST        !timeANDcapacityANDallocation-time !lecturerANDallocation-time
   /edit                       CEditR           GET POST
   /lecturer-invite            CLecInviteR      GET POST
-  /delete                     CDeleteR         GET POST        !lecturerANDempty
+  /delete                     CDeleteR         GET POST        !lecturerANDemptyANDallocation-time
   /users                      CUsersR          GET POST
-  !/users/new                 CAddUserR        GET POST
+  !/users/new                 CAddUserR        GET POST        !lecturerANDallocation-time
   !/users/invite              CInviteR         GET POST
   /users/#CryptoUUIDUser      CUserR           GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR          GET

shell.nix

@@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> }:
+{ nixpkgs ? import ./nixpkgs.nix {} }:
 
 let
   inherit (nixpkgs {}) pkgs;

src/Application.hs

@@ -38,8 +38,6 @@ import System.Log.FastLogger                ( defaultBufSize, newStderrLoggerSet
 
 import Handler.Utils                        (runAppLoggingT)
 
-import qualified Data.Map.Strict as Map
-
 import Foreign.Store
 
 import qualified Data.UUID as UUID
@@ -158,8 +156,7 @@ makeFoundation appSettings'@AppSettings{..} = do
 
     appInstanceID <- liftIO $ maybe UUID.nextRandom (either readInstanceIDFile return) appInitialInstanceID
 
-    appJobCtl <- liftIO $ newTVarIO Map.empty
+    appJobState <- liftIO newEmptyTMVarIO
-    appCronThread <- liftIO newEmptyTMVarIO
     appHealthReport <- liftIO $ newTVarIO Set.empty
 
     -- We need a log function to create a connection pool. We need a connection
@@ -371,7 +368,7 @@ develMain = runResourceT $ do
   wsettings <- liftIO . getDevSettings $ warpSettings foundation
   app <- makeApplication foundation
 
-  handleJobs foundation
+  runAppLoggingT foundation $ handleJobs foundation
   liftIO . develMainHelper $ return (wsettings, app)
 
 -- | The @main@ function for an executable running this site.
@@ -471,7 +468,7 @@ getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWor
 getApplicationRepl = do
     settings <- getAppDevSettings
     foundation <- makeFoundation settings
-    handleJobs foundation
+    runAppLoggingT foundation $ handleJobs foundation
     wsettings <- liftIO . getDevSettings $ warpSettings foundation
     app1 <- makeApplication foundation
 
@@ -481,7 +478,7 @@ getApplicationRepl = do
 
     return (getPort wsettings, foundation, app1)
 
-shutdownApp :: MonadIO m => UniWorX -> m ()
+shutdownApp :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
 shutdownApp app = do
   stopJobCtl app
   liftIO $ do

src/Audit.hs

@@ -1,17 +1,20 @@
 module Audit
   ( module Audit.Types
   , AuditException(..)
-  , audit, audit'
+  , audit
   , AuditRemoteException(..)
   , getRemote
   ) where
 
 
 import Import.NoModel
+import Settings
 import Model
 import Database.Persist.Sql
 import Audit.Types
 
+import qualified Data.Text.Encoding as Text
+
 import Utils.Lens
 import qualified Network.Wai as Wai
 import qualified Network.Socket as Wai
@@ -27,58 +30,63 @@ data AuditRemoteException
 instance Exception AuditRemoteException
 
 
-getRemote :: (MonadHandler m, MonadThrow m) => m IP
+getRemote :: (MonadHandler m, MonadThrow m, HasAppSettings (HandlerSite m)) => m IP
 getRemote = do
+  ipFromHeader <- getsYesod $ view _appIpFromHeader
   wai <- waiRequest
-  case Wai.remoteHost wai of
+
-    Wai.SockAddrInet _ hAddr -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr in return $ IP.ipv4 b1 b2 b3 b4
+  if
-    Wai.SockAddrInet6 _ _ hAddr _ -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
+    | ipFromHeader
-    _other -> throwM ARUnsupportedSocketKind
+    , Just ip <- byHeader wai
+      -> return ip
+    | otherwise
+      -> byRemoteHost wai
+  
+  where
+    byHeader wai = listToMaybe $ do
+      (h, v) <- Wai.requestHeaders wai
+      guard $ h `elem` ["x-real-ip", "x-forwarded-for"]
+      v' <- either (const mzero) return $ Text.decodeUtf8' v
+      maybeToList $ IP.decode v'
+    
+    byRemoteHost wai = case Wai.remoteHost wai of
+      Wai.SockAddrInet _ hAddr
+        -> let (b1, b2, b3, b4) = Wai.hostAddressToTuple hAddr
+            in return $ IP.ipv4 b1 b2 b3 b4
+      Wai.SockAddrInet6 _ _ hAddr _
+        -> let (w1, w2, w3, w4, w5, w6, w7, w8) = Wai.hostAddress6ToTuple hAddr
+            in return $ IP.ipv6 w1 w2 w3 w4 w5 w6 w7 w8
+      _other -> throwM ARUnsupportedSocketKind
 
 
 data AuditException
   = AuditRemoteException AuditRemoteException
-  | AuditUserNotFound UserId
   deriving (Show, Generic, Typeable)
 instance Exception AuditException
 
 
-audit :: ( AuthId site ~ Key User
+audit :: ( AuthId (HandlerSite m) ~ Key User
-         , AuthEntity site ~ User
+         , AuthEntity (HandlerSite m) ~ User
-         , IsSqlBackend (YesodPersistBackend site)
+         , IsSqlBackend (YesodPersistBackend (HandlerSite m))
-         , SqlBackendCanWrite (YesodPersistBackend site)
+         , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
-         , HasInstanceID site InstanceId
+         , HasInstanceID (HandlerSite m) InstanceId
-         , YesodAuthPersist site
+         , YesodAuthPersist (HandlerSite m)
+         , MonadHandler m
+         , MonadCatch m
+         , HasAppSettings (HandlerSite m)
          )
       => Transaction -- ^ Transaction to record
-      -> [UserId] -- ^ Affected users
+      -> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
-      -> YesodDB site ()
 -- ^ Log a transaction using information available from `HandlerT`:
 --
 --   - `transactionLogTime` is now
 --   - `transactionLogInitiator` is currently logged in user (or none)
 --   - `transactionLogRemote` is determined from current HTTP-Request
-audit (toJSON -> transactionLogInfo) affected = do
+audit (toJSON -> transactionLogInfo) = do
-  uid <- liftHandlerT maybeAuthId
 
   transactionLogTime <- liftIO getCurrentTime
   transactionLogInstance <- getsYesod $ view instanceID
-  transactionLogInitiator <- for uid $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
+  transactionLogInitiator <- liftHandlerT maybeAuthId
   transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote
 
-  tlId <- insert TransactionLog{..}
+  insert_ TransactionLog{..}
-
-  affectedUsers <- forM affected $ \uid' -> maybe (throwM $ AuditUserNotFound uid') (return . userIdent) =<< get uid'
-  insertMany_ $ map (TransactionLogAffected tlId) affectedUsers
-
-audit' :: ( AuthId site ~ Key User
-          , AuthEntity site ~ User
-          , IsSqlBackend (YesodPersistBackend site)
-          , SqlBackendCanWrite (YesodPersistBackend site)
-          , HasInstanceID site InstanceId
-          , YesodAuthPersist site
-          )
-       => Transaction -- ^ Transaction to record
-       -> YesodDB site ()
--- ^ Special case of `audit` for when there are no affected users
-audit' = flip audit []

src/Audit/Types.hs

@@ -12,21 +12,23 @@ import Utils.PathPiece
 
 data Transaction
   = TransactionTermEdit
-    { transactionTerm   :: TermIdentifier
+    { transactionTerm   :: TermId
     }
   | TransactionExamRegister
-    { transactionTerm   :: TermIdentifier
+    { transactionExam   :: ExamId
-    , transactionSchool :: SchoolShorthand
+    , transactionUser   :: UserId
-    , transactionCourse :: CourseShorthand
-    , transactionExam   :: ExamName
-    , transactionUser   :: UserIdent
     }
   | TransactionExamDeregister
-    { transactionTerm   :: TermIdentifier
+    { transactionExam   :: ExamId
-    , transactionSchool :: SchoolShorthand
+    , transactionUser   :: UserId
-    , transactionCourse :: CourseShorthand
+    }
-    , transactionExam   :: ExamName
+  | TransactionExamResultEdit
-    , transactionUser   :: UserIdent
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
+    }
+  | TransactionExamResultDeleted
+    { transactionExam   :: ExamId
+    , transactionUser   :: UserId
     }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 

src/Auth/LDAP.hs

@@ -1,9 +1,12 @@
 module Auth.LDAP
-  ( campusLogin
+  ( apLdap
+  , campusLogin
   , CampusUserException(..)
   , campusUser
   , CampusMessage(..)
-  , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
+  , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
+  , ldapUserMatriculation, ldapUserFirstName, ldapUserSurname
+  , ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName
   ) where
 
 import Import.NoFoundation hiding (userEmail, userDisplayName)
@@ -42,12 +45,12 @@ findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
 findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase userSearchSettings) retAttrs) userFilters
   where
     userFilters =
-      [ userPrincipalName Ldap.:= Text.encodeUtf8 ident
+      [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
-      , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 ident
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 ident
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|]
-      , userEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
+      , ldapUserEmail         Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|]
-      , userDisplayName   Ldap.:= Text.encodeUtf8 ident
+      , ldapUserDisplayName   Ldap.:= Text.encodeUtf8 ident
       ]
     userSearchSettings = mconcat
       [ Ldap.scope ldapScope
@@ -56,10 +59,53 @@ findUser LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not
       , Ldap.derefAliases Ldap.DerefAlways
       ]
 
-userPrincipalName, userEmail, userDisplayName :: Ldap.Attr
+ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr
-userPrincipalName = Ldap.Attr "userPrincipalName"
+ldapUserPrincipalName = Ldap.Attr "userPrincipalName"
-userEmail         = Ldap.Attr "mail"
+ldapUserEmail         = Ldap.Attr "mail"
-userDisplayName   = Ldap.Attr "displayName"
+ldapUserDisplayName   = Ldap.Attr "displayName"
+ldapUserMatriculation = Ldap.Attr "LMU-Stud-Matrikelnummer"
+ldapUserFirstName     = Ldap.Attr "givenName"
+ldapUserSurname       = Ldap.Attr "sn"
+ldapUserTitle         = Ldap.Attr "title"
+ldapUserStudyFeatures = Ldap.Attr "dfnEduPersonFeaturesOfStudy"
+ldapUserFieldName     = Ldap.Attr "dfnEduPersonFieldOfStudyString" 
+
+
+data CampusUserException = CampusUserLdapError LdapPoolError
+                         | CampusUserHostNotResolved String
+                         | CampusUserLineTooLong
+                         | CampusUserHostCannotConnect String [IOException]
+                         | CampusUserNoResult
+                         | CampusUserAmbiguous
+  deriving (Show, Eq, Generic, Typeable)
+
+instance Exception CampusUserException
+
+campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
+campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+  Ldap.bind ldap ldapDn ldapPassword
+  results <- case lookup "DN" credsExtra of
+    Just userDN -> do
+      let userFilter = Ldap.Present ldapUserPrincipalName
+          userSearchSettings = mconcat
+            [ Ldap.scope Ldap.BaseObject
+            , Ldap.size 2
+            , Ldap.time ldapSearchTimeout
+            , Ldap.derefAliases Ldap.DerefAlways
+            ]
+      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
+    Nothing -> do
+      findUser conf ldap credsIdent []
+  case results of
+    [] -> throwM CampusUserNoResult
+    [Ldap.SearchEntry _ attrs] -> return attrs
+    _otherwise -> throwM CampusUserAmbiguous
+  where
+    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
+                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
+                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
+                  ]
+
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
@@ -69,6 +115,9 @@ campusForm = CampusLogin
   <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
   <*> areq passwordField (fslI MsgCampusPassword) Nothing
 
+apLdap :: Text
+apLdap = "LDAP"
+
 campusLogin :: forall site.
                ( YesodAuth site
                , RenderMessage site FormMessage
@@ -78,7 +127,7 @@ campusLogin :: forall site.
                ) => LdapConf -> LdapPool -> AuthPlugin site
 campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
-    apName = "LDAP"
+    apName = apLdap
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
     apDispatch "POST" [] = do
       ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
@@ -90,10 +139,10 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
         FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
           ldapResult <- withLdap pool $ \ldap -> do
             Ldap.bind ldap ldapDn ldapPassword
-            searchResults <- findUser conf ldap campusIdent [userPrincipalName]
+            searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
             case searchResults of
               [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]
-                | Just [principalName] <- lookup userPrincipalName userAttrs
+                | [principalName] <- fold [ v | (k, v) <- userAttrs, k == ldapUserPrincipalName ]
                 , Right credsIdent <- Text.decodeUtf8' principalName
                 -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
               other -> return $ Left other
@@ -123,55 +172,3 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
             , formAnchor = Just "login--campus" :: Maybe Text
             }
       $(widgetFile "widgets/campus-login/campus-login-form")
-
-data CampusUserException = CampusUserLdapError LdapPoolError
-                         | CampusUserHostNotResolved String
-                         | CampusUserLineTooLong
-                         | CampusUserHostCannotConnect String [IOException]
-                         | CampusUserNoResult
-                         | CampusUserAmbiguous
-  deriving (Show, Eq, Generic, Typeable)
-
-instance Exception CampusUserException
-
-campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
-campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
-  Ldap.bind ldap ldapDn ldapPassword
-  results <- case lookup "DN" credsExtra of
-    Just userDN -> do
-      let userFilter = Ldap.Present userPrincipalName
-          userSearchSettings = mconcat
-            [ Ldap.scope Ldap.BaseObject
-            , Ldap.size 2
-            , Ldap.time ldapSearchTimeout
-            , Ldap.derefAliases Ldap.DerefAlways
-            ]
-      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
-    Nothing -> do
-      findUser conf ldap credsIdent []
-  case results of
-    [] -> throwM CampusUserNoResult
-    [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM CampusUserAmbiguous
-  where
-    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
-                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
-                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
-                  ]
-
--- ldapConfig :: UniWorX -> LDAPConfig
--- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
---   { usernameFilter = \u -> principalName <> "=" <> u
---   , identifierModifier
---   , ldapUri = appLDAPURI settings
---   , initDN = appLDAPDN settings
---   , initPass = appLDAPPw settings
---   , baseDN = appLDAPBaseName settings
---   , ldapScope = LdapScopeSubtree
---   }
---   where
---     principalName :: IsString a => a
---     principalName = "userPrincipalName"
---     identifierModifier _ entry = case lookup principalName $ leattrs entry of
---       Just [n] -> Text.pack n
---       _        -> error "Could not determine user principal name"

src/Control/Concurrent/Async/Lifted/Safe/Utils.hs

@@ -0,0 +1,17 @@
+module Control.Concurrent.Async.Lifted.Safe.Utils
+  ( allocateAsync, allocateLinkedAsync
+  ) where
+
+import ClassyPrelude hiding (cancel)
+import Control.Lens
+
+import Control.Concurrent.Async.Lifted.Safe
+
+import Control.Monad.Trans.Resource
+
+
+allocateLinkedAsync, allocateAsync :: forall m a.
+                                      MonadResource m
+                                   => IO a -> m (Async a)
+allocateAsync = fmap (view _2) . flip allocate cancel . async
+allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync

src/Cron.hs

@@ -23,7 +23,7 @@ import Utils.Lens hiding (from, to)
 
   
 data CronDate = CronDate
-  { cdYear, cdWeekOfYear, cdDayOfYear
+  { cdYear, cdWeekYear, cdWeekOfYear, cdDayOfYear
   , cdMonth, cdWeekOfMonth, cdDayOfMonth
   , cdDayOfWeek
   , cdHour, cdMinute, cdSecond :: Natural
@@ -48,7 +48,7 @@ toCronDate LocalTime{..} = CronDate{..}
       = toGregorian localDay
     (_, fromIntegral -> cdDayOfYear)
       = toOrdinalDate localDay
-    (_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
+    (fromInteger -> cdWeekYear, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
       = toWeekDate localDay
     cdWeekOfMonth = go 1 localDay
       where
@@ -60,8 +60,8 @@ toCronDate LocalTime{..} = CronDate{..}
           where
             (y, w, dow) = toWeekDate day
             day'
-              | w /= 0 = fromWeekDate y (pred w) dow
+              | w > 1     = fromWeekDate y        (pred w) dow
-              | otherwise = fromWeekDate (pred y) 53 dow
+              | otherwise = fromWeekDate (pred y) 53       dow
             (_, m, _) = toGregorian day
             (_, m', _) = toGregorian day'
     TimeOfDay
@@ -73,7 +73,7 @@ toCronDate LocalTime{..} = CronDate{..}
 consistentCronDate :: CronDate -> Bool
 consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
   gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
-  wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
+  wDay <- fromWeekDateValid (fromIntegral cdWeekYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
   guard $ gDay == wDay
   oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
   guard $ wDay == oDay
@@ -107,39 +107,40 @@ listToMatch (t:_) = MatchAt t
 
 genMatch :: Int -- ^ Period
          -> Bool -- ^ Modular
+         -> Bool -- ^ Zero based
          -> Natural -- ^ Start value
          -> CronMatch
          -> [Natural]
-genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
+genMatch p m z st CronMatchAny = take p $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [st..]
-genMatch _ _ _ CronMatchNone = []
+genMatch _ _ _ _ CronMatchNone = []
-genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs
+genMatch p m z _ (CronMatchSome xs) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) . Set.toAscList $ toNullable xs
-genMatch p m st (CronMatchStep step) = do
+genMatch p m z st (CronMatchStep step) = do
   start <- [st..st + step]
   guard $ (start `mod` step) == 0
-  take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
+  take (ceiling $ fromIntegral p % step) $ map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) [start,start + step..]
-genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
+genMatch p m z st (CronMatchContiguous from to) = take p . map (bool id (bool succ id z . (`mod` fromIntegral p) . bool pred id z) m) $ [max st from..to]
-genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
+genMatch _ _ _ _ (CronMatchIntersect CronMatchNone _) = []
-genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
+genMatch _ _ _ _ (CronMatchIntersect _ CronMatchNone) = []
-genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
+genMatch p m z st (CronMatchIntersect CronMatchAny other) = genMatch p m z st other
-genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
+genMatch p m z st (CronMatchIntersect other CronMatchAny) = genMatch p m z st other
-genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
+genMatch p m z st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
-  = genMatch p m st . CronMatchStep $ lcm st1 st2
+  = genMatch p m z st . CronMatchStep $ lcm st1 st2
-genMatch p m st (CronMatchIntersect aGen bGen)
+genMatch p m z st (CronMatchIntersect aGen bGen)
   | [] <- as' = []
-  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
+  | (a:as) <- as' = mergeAnd (a:as) (genMatch p m z a bGen)
   where
-    as' = genMatch p m st aGen
+    as' = genMatch p m z st aGen
     mergeAnd [] _ = []
     mergeAnd _ [] = []
     mergeAnd (a:as) (b:bs)
       | a <  b    = mergeAnd as (b:bs)
       | a == b    = a : mergeAnd as bs
       | otherwise = mergeAnd (a:as) bs
-genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
+genMatch p m z st (CronMatchUnion CronMatchNone other) = genMatch p m z st other
-genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
+genMatch p m z st (CronMatchUnion other CronMatchNone) = genMatch p m z st other
-genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
+genMatch p m z st (CronMatchUnion CronMatchAny _) = genMatch p m z st CronMatchAny
-genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
+genMatch p m z st (CronMatchUnion _ CronMatchAny) = genMatch p m z st CronMatchAny
-genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
+genMatch p m z st (CronMatchUnion aGen bGen) = merge (genMatch p m z st aGen) (genMatch p m z st bGen)
   where
     merge [] bs = bs
     merge as [] = as
@@ -215,28 +216,134 @@ nextCronMatch tz mPrev prec now c@Cron{..} = case notAfter of
         | ref <= ts || not wasExecd -> MatchAt ts
         | otherwise -> MatchNone
       CronCalendar{..} -> listToMatch $ do
-        let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
+        let
+          localRef = utcToLocalTimeTZ tz ref
+          CronDate{..} = toCronDate localRef
+
+        mCronWeekDate <- if
+          | cronWeekYear == CronMatchAny
+          , cronWeekOfYear == CronMatchAny
+          , cronDayOfWeek == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> genMatch 53 True False cdWeekOfYear cronWeekOfYear
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+
+        mCronGregorianDate <- if
+          | cronYear == CronMatchAny
+          , cronMonth == CronMatchAny
+          , cronDayOfMonth == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 400 False True cdYear cronYear
+               <*> genMatch 12 True False cdMonth cronMonth
+               <*> genMatch 31 True False cdDayOfMonth cronDayOfMonth
+
+        mCronWeekOfMonthDate <- if
+          | cronWeekOfMonth == CronMatchAny
+            -> return Nothing
+          | Just (wY, _, wd) <- mCronWeekDate
+            -> fmap Just $ (,,,)
+                 <$> pure wY
+                 <*> maybe (genMatch 12 True False cdMonth cronMonth) (pure . view _2) mCronGregorianDate
+                 <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+                 <*> pure wd
+          | Just (_, m, _) <- mCronGregorianDate
+            -> fmap Just $ (,,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> pure m
+               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+          | otherwise
+            -> fmap Just $ (,,,)
+               <$> genMatch 400 False True cdWeekYear cronWeekYear
+               <*> genMatch 12 True False cdMonth cronMonth
+               <*> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+               <*> genMatch 7 True False cdDayOfWeek cronDayOfWeek
+
+        mCronOrdinalDate <- if
+          | cronYear == CronMatchAny
+          , cronDayOfYear == CronMatchAny
+            -> return Nothing
+          | Just (y, _, _) <- mCronGregorianDate
+            -> Just . (y,) <$> genMatch 366 True False cdDayOfYear cronDayOfYear
+          | otherwise
+            -> fmap Just $ (,)
+               <$> genMatch 400 False True cdYear cronYear
+               <*> genMatch 366 True False cdDayOfYear cronDayOfYear
+
+        mCronTime <- if
+          | cronHour == CronMatchAny
+          , cronMinute == CronMatchAny
+          , cronSecond == CronMatchAny
+            -> return Nothing
+          | otherwise
+            -> fmap Just $ (,,)
+               <$> genMatch 24 True True cdHour cronHour
+               <*> genMatch 60 True True cdMinute cronMinute
+               <*> genMatch 60 True True cdSecond cronSecond
+
+        let toGregorian' = over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral . toGregorian
+        (mCronYear, mCronMonth, mCronDayOfMonth) <- if
+            | Just (year, month, dayOfMonth) <- mCronGregorianDate
+              -> return (year, month, dayOfMonth)
+            | Just (weekYear, week, dayOfWeek) <- mCronWeekDate
+              -> return . toGregorian' $ fromWeekDate (fromIntegral weekYear) (fromIntegral week) (fromIntegral dayOfWeek)
+            | Just (year, dayOfYear) <- mCronOrdinalDate
+              -> maybeToList . fmap toGregorian' $ fromOrdinalDateValid (fromIntegral year) (fromIntegral dayOfYear)
+            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
+              -> do
+                   year <- genMatch 400 False True cdYear cronYear
+                   day <- genMatch 31 True False cdDayOfMonth cronDayOfMonth
+                   jDay <- maybeToList $ fromGregorianValid (fromIntegral year) (fromIntegral month) (fromIntegral day)
+                   guard $ consistentCronDate (toCronDate localRef{ localDay = jDay }) { cdWeekYear = weekYear, cdMonth = month, cdWeekOfMonth = weekOfMonth, cdDayOfWeek = dayOfWeek }
+                   return (year, month, day)
+            | otherwise
+              -> fmap toGregorian' [localDay localRef, succ $ localDay localRef]
+
+        julDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
+
+        mCronDayOfYear <- if
+            | Just (year, dayOfYear) <- mCronOrdinalDate
+              -> dayOfYear <$ guard (year == mCronYear)
+            | otherwise
+              -> return . fromIntegral . snd $ toOrdinalDate julDay
+
+        (mCronWeekYear, mCronWeekOfYear, mCronDayOfWeek) <- if
+            | Just weekDate <- mCronWeekDate
+              -> return weekDate
+            | otherwise
+              -> return . over _1 fromIntegral . over _2 fromIntegral . over _3 fromIntegral $ toWeekDate julDay
+
+        mCronWeekOfMonth <- if
+            | Just (weekYear, month, weekOfMonth, dayOfWeek) <- mCronWeekOfMonthDate
+              -> weekOfMonth <$ guard (weekYear == mCronWeekYear && month == mCronMonth && dayOfWeek == mCronDayOfWeek)
+            | otherwise
+              -> genMatch 5 True False cdWeekOfMonth cronWeekOfMonth
+
+        (mCronHour, mCronMinute, mCronSecond) <- if
+            | Just (h, m, s) <- mCronTime
+              -> return (h, m, s)
+            | otherwise
+              -> [(0, 0, 0), (cdHour, cdMinute, cdSecond)]
 
-        mCronYear <- genMatch 400 False cdYear cronYear
-        mCronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
-        mCronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
-        mCronMonth <- genMatch 12 True cdMonth cronMonth
-        mCronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
-        mCronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
-        mCronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
-        mCronHour <- genMatch 24 True cdHour cronHour
-        mCronMinute <- genMatch 60 True cdMinute cronMinute
-        mCronSecond <- genMatch 60 True cdSecond cronSecond
         guard $ consistentCronDate CronDate
           { cdYear = mCronYear, cdMonth = mCronMonth, cdDayOfMonth = mCronDayOfMonth
           , cdHour = mCronHour, cdMinute = mCronMinute, cdSecond = mCronSecond
-          , cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
+          , cdWeekYear = mCronWeekYear, cdWeekOfYear = mCronWeekOfYear, cdWeekOfMonth = mCronWeekOfMonth
           , cdDayOfYear = mCronDayOfYear, cdDayOfWeek = mCronDayOfWeek
           }
 
         localDay <- maybeToList $ fromGregorianValid (fromIntegral mCronYear) (fromIntegral mCronMonth) (fromIntegral mCronDayOfMonth)
         let localTimeOfDay = TimeOfDay (fromIntegral mCronHour) (fromIntegral mCronMinute) (fromIntegral mCronSecond)
-        return $ localTimeToUTCTZ tz LocalTime{..}
+            res = localTimeToUTCTZ tz LocalTime{..}
+
+        guard $ res >= ref
+
+        return res
       CronNotScheduled -> MatchNone
 
 matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry

src/Cron/Types.hs

@@ -1,7 +1,9 @@
 module Cron.Types
   ( Cron(..), Crontab
   , CronMatch(..)
+  , cronMatchOne
   , CronAbsolute(..)
+  , cronCalendarAny
   , CronRepeat(..)
   ) where
 
@@ -14,6 +16,7 @@ import Data.Time
 import Numeric.Natural
 
 import Data.HashMap.Strict (HashMap)
+import qualified Data.Set as Set
   
 
 data CronMatch
@@ -26,13 +29,16 @@ data CronMatch
   | CronMatchUnion CronMatch CronMatch
   deriving (Eq, Show, Read)
 
+cronMatchOne :: Natural -> CronMatch
+cronMatchOne = CronMatchSome . impureNonNull . Set.singleton
+
 data CronAbsolute
   = CronAsap
   | CronTimestamp
     { cronTimestamp :: LocalTime
     }
   | CronCalendar
-    { cronYear, cronWeekOfYear, cronDayOfYear
+    { cronYear, cronWeekYear, cronWeekOfYear, cronDayOfYear
     , cronMonth, cronWeekOfMonth, cronDayOfMonth
     , cronDayOfWeek
     , cronHour, cronMinute, cronSecond :: CronMatch
@@ -42,6 +48,21 @@ data CronAbsolute
 
 makeLenses_ ''CronAbsolute
 
+cronCalendarAny :: CronAbsolute
+cronCalendarAny = CronCalendar
+  { cronYear        = CronMatchAny
+  , cronWeekYear    = CronMatchAny
+  , cronWeekOfYear  = CronMatchAny
+  , cronDayOfYear   = CronMatchAny
+  , cronMonth       = CronMatchAny
+  , cronWeekOfMonth = CronMatchAny
+  , cronDayOfMonth  = CronMatchAny
+  , cronDayOfWeek   = CronMatchAny
+  , cronHour        = CronMatchAny
+  , cronMinute      = CronMatchAny
+  , cronSecond      = CronMatchAny
+  }
+
 data CronRepeat
   = CronRepeatOnChange
   | CronRepeatScheduled CronAbsolute

src/CryptoID.hs

@@ -45,6 +45,7 @@ decCryptoIDs [ ''SubmissionId
              , ''StudyFeaturesId
              , ''ExamOccurrenceId
              , ''ExamPartId
+             , ''AllocationId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Data/Fixed/Instances.hs

@@ -10,10 +10,12 @@ import Data.Fixed
 import Text.Blaze (ToMarkup(..))
 
 import qualified Data.Csv as Csv
+import Web.PathPieces
 
 import Data.Proxy (Proxy(..))
 
 import Data.Scientific
+import Data.Scientific.Instances ()
   
 
 instance HasResolution a => ToMarkup (Fixed a) where
@@ -24,3 +26,7 @@ instance HasResolution a => Csv.ToField (Fixed a) where
   toField = Csv.toField . (realToFrac :: Fixed a -> Scientific)
 instance HasResolution a => Csv.FromField (Fixed a) where
   parseField = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . Csv.parseField
+
+instance HasResolution a => PathPiece (Fixed a) where
+  toPathPiece = toPathPiece . (realToFrac :: Fixed a -> Scientific)
+  fromPathPiece = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . fromPathPiece

src/Data/Scientific/Instances.hs

@@ -0,0 +1,15 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.Scientific.Instances
+  (
+  ) where
+
+import ClassyPrelude
+import Data.Scientific
+
+import Web.PathPieces
+
+
+instance PathPiece Scientific where
+  toPathPiece = pack . formatScientific Fixed Nothing 
+  fromPathPiece = readFromPathPiece

src/Database/Esqueleto/Utils.hs

@@ -11,8 +11,10 @@ module Database.Esqueleto.Utils
   , mkContainsFilter, mkContainsFilterWith
   , mkExistsFilter
   , anyFilter, allFilter
+  , orderByList
   , orderByOrd, orderByEnum
   , lower, ciEq
+  , selectExists
   ) where
 
 
@@ -29,6 +31,10 @@ import Database.Esqueleto.Utils.TH
 {-# ANN all ("HLint: ignore Use all" :: String) #-}
 
 
+{-# ANN any ("HLint: ignore Use any" :: String) #-}
+{-# ANN all ("HLint: ignore Use all" :: String) #-}
+
+
 --
 -- Description : Convenience for using `Esqueleto`,
 --               intended to be imported qualified
@@ -167,12 +173,16 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs
     aux fltr acc = fltr needle criterias E.&&. acc
 
 
+orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
+orderByList vals
+  = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
+     in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
+  
 orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
-orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
+orderByOrd = orderByList $ List.sort universeF
-    \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
 
 orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
-orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1))
+orderByEnum = orderByList $ List.sortOn fromEnum universeF
 
 
 lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
@@ -180,3 +190,12 @@ lower = E.unsafeSqlFunction "LOWER"
 
 ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
 ciEq a b = lower a E.==. lower b
+
+
+selectExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool
+selectExists query = do
+  res <- E.select . return . E.exists $ void query
+
+  case res of
+    [E.Value b] -> return b
+    _other      -> error "SELECT EXISTS ... returned zero or more than one rows"

src/Foundation.hs

@@ -5,7 +5,7 @@
 module Foundation where
 
 import Import.NoFoundation hiding (embedFile)
-import qualified ClassyPrelude.Yesod as Yesod (addMessage, getHttpManager)
+import qualified ClassyPrelude.Yesod as Yesod (getHttpManager)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 
@@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode)
 
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as Lazy.ByteString
+import qualified Data.ByteString as ByteString
 
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
@@ -54,7 +55,7 @@ import Data.Conduit.List (sourceList)
 
 import qualified Database.Esqueleto as E
 
-import Control.Monad.Except (MonadError(..), ExceptT, runExceptT)
+import Control.Monad.Except (MonadError(..), ExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Trans.Reader (runReader, mapReaderT)
 import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
@@ -87,6 +88,8 @@ import qualified Data.Aeson as JSON
 
 import Data.FileEmbed (embedFile)
 
+import qualified Ldap.Client as Ldap
+
 
 type SMTPPool = Pool SMTPConnection
 
@@ -110,8 +113,7 @@ data UniWorX = UniWorX
     , appCryptoIDKey     :: CryptoIDKey
     , appClusterID       :: ClusterId
     , appInstanceID      :: InstanceId
-    , appJobCtl          :: TVar (Map ThreadId (TMChan JobCtl))
+    , appJobState        :: TMVar JobState
-    , appCronThread      :: TMVar (ReleaseKey, ThreadId)
     , appSessionKey      :: ClientSession.Key
     , appSecretBoxKey    :: SecretBox.Key
     , appJSONWebKeySet   :: Jose.JwkSet
@@ -296,6 +298,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id
 embedRenderMessage ''UniWorX ''SecretJSONFieldException id
 embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
 
+embedRenderMessage ''UniWorX ''AuthenticationMode id
 
 newtype SheetTypeHeader = SheetTypeHeader SheetType
 embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@@ -335,6 +338,24 @@ instance RenderMessage UniWorX StudyDegreeTerm where
 instance RenderMessage UniWorX ExamGrade where
   renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
 
+instance RenderMessage UniWorX ExamPassed where
+  renderMessage foundation ls = \case
+    ExamPassed True  -> mr MsgExamPassed
+    ExamPassed False -> mr MsgExamNotPassed
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
+  renderMessage foundation ls = \case
+    ExamAttended{..} -> mr examResult
+    ExamNoShow       -> mr MsgExamResultNoShow
+    ExamVoided       -> mr MsgExamResultVoided
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+
 -- ToMessage instances for converting raw numbers to Text (no internationalization)
 
 instance ToMessage Int where
@@ -774,6 +795,52 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
     return Authorized
 
   r -> $unsupportedAuthPredicate AuthTime r
+tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
+  CourseR tid ssh csh CRegisterR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Nothing -> return Authorized
+      Just (cid, Allocation{..}) -> do
+        registered <- case mAuthId of
+          Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid
+          _        -> return False
+        if
+          | not registered
+          , NTop allocationRegisterByCourse >= NTop (Just now)
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+          | registered
+          , NTop (Just now) >= NTop allocationOverrideDeregister
+            -> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister
+          | otherwise
+            -> return Authorized
+
+  CourseR tid ssh csh CAddUserR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Just (_, Allocation{..})
+        |    NTop allocationStaffRegisterTo <= NTop (Just now)
+          || NTop allocationStaffRegisterFrom >= NTop (Just now)
+          -> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
+      _other -> return Authorized
+
+  CourseR tid ssh csh CDeleteR -> do
+    now <- liftIO getCurrentTime
+    mba <- mbAllocation tid ssh csh
+    case mba of
+      Just (_, Allocation{..})
+        | NTop allocationRegisterByStaffTo <= NTop (Just now)
+          || NTop allocationRegisterByStaffFrom >= NTop (Just now)
+          -> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
+      _other -> return Authorized
+
+  r -> $unsupportedAuthPredicate AuthAllocationTime r
+  where
+    mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
+      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
+      (cid,) <$> MaybeT (get allocationCourseAllocation)
 tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
   CourseR tid ssh csh _ -> exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@@ -983,6 +1050,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret
     AdminUserDeleteR cID -> return cID
     AdminHijackUserR cID -> return cID
     UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
     _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
   referencedUser' <- decrypt referencedUser
@@ -991,6 +1059,34 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret
       | uid == referencedUser' -> return Authorized
     Nothing -> return AuthenticationRequired
     _other  -> unauthorizedI MsgUnauthorizedSelf
+tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
+  referencedUser' <- decrypt referencedUser
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
+    User{..} <- MaybeT $ get referencedUser'
+    guard $ userAuthentication == AuthLDAP
+  return Authorized
+tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do
+  referencedUser <- case route of
+    AdminUserR cID -> return cID
+    AdminUserDeleteR cID -> return cID
+    AdminHijackUserR cID -> return cID
+    UserNotificationR cID -> return cID
+    UserPasswordR cID -> return cID
+    CourseR _ _ _ (CUserR cID) -> return cID
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
+  referencedUser' <- decrypt referencedUser
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
+    User{..} <- MaybeT $ get referencedUser'
+    guard $ is _AuthPWHash userAuthentication
+  return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
     smId <- decrypt cID
@@ -1215,9 +1311,8 @@ instance Yesod UniWorX where
             , massInputShortcircuit
             ]
 
-          lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
+          lift . bracketOnError getMessages (mapM_ addMessage') $
-            Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
+            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode
-            addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs'
 
     -- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
     defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
@@ -1434,6 +1529,7 @@ siteLayout' headingOverride widget = do
       addScript $ StaticR bundles_js_polyfills_js
       addScript $ StaticR bundles_js_vendor_js
       addScript $ StaticR bundles_js_main_js
+      toWidget $(juliusFile "templates/i18n.julius")
       -- widgets
       $(widgetFile "default-layout")
   withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
@@ -1526,6 +1622,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
   breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
   breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
+  breadcrumb (CExamR tid ssh csh examn EAddUserR)  = return ("Klausurteilnehmer hinzufügen", Just $ CExamR tid ssh csh examn EUsersR)
 
   breadcrumb (CTutorialR tid ssh csh tutn TUsersR)   = return (original tutn, Just $ CourseR tid ssh csh CTutorialListR)
   breadcrumb (CTutorialR tid ssh csh tutn TEditR)    = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR)
@@ -1708,6 +1805,14 @@ pageActions (HomeR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuCourseNew
+      , menuItemIcon  = Just "book"
+      , menuItemRoute = SomeRoute CourseNewR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ,  MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgAdminHeading
@@ -1783,8 +1888,18 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
-pageActions (AdminUserR cID) = [
+pageActions (UsersR) =
-    MenuItem
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuLecturerInvite
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute AdminNewLecturerInviteR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (AdminUserR cID) =
+  [ MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgMenuUserNotifications
       , menuItemIcon  = Nothing
@@ -1792,6 +1907,17 @@ pageActions (AdminUserR cID) = [
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuUserPassword
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ UserPasswordR cID
+      , menuItemModal = True
+      , menuItemAccessCallback' = do
+          uid <- decrypt cID
+          User{userAuthentication} <- runDB $ get404 uid
+          return $ is _AuthPWHash userAuthentication
+      }
   ]
 pageActions (InfoR) = [
     MenuItem
@@ -2218,6 +2344,16 @@ pageActions (CExamR tid ssh csh examn EShowR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (CExamR tid ssh csh examn EUsersR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuExamAddMembers
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EAddUserR
+      , menuItemModal = True
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (CSheetR tid ssh csh shn SShowR) =
   [ MenuItem
       { menuItemType  = PageActionPrime
@@ -2652,6 +2788,155 @@ instance YesodPersist UniWorX where
 instance YesodPersistRunner UniWorX where
     getDBRunner = defaultGetDBRunner appConnPool
 
+data CampusUserConversionException
+  = CampusUserInvalidEmail
+  | CampusUserInvalidDisplayName
+  | CampusUserInvalidGivenName
+  | CampusUserInvalidSurname
+  | CampusUserInvalidTitle
+  | CampusUserInvalidMatriculation
+  | CampusUserInvalidFeaturesOfStudy String
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+instance Exception CampusUserConversionException
+
+embedRenderMessage ''UniWorX ''CampusUserConversionException id
+
+upsertCampusUser :: Ldap.AttrList [] -> Creds UniWorX -> DB (Entity User)
+upsertCampusUser ldapData Creds{..} = do
+  now <- liftIO getCurrentTime
+  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+
+  let
+    userMatrikelnummer' = fold [ v | (k, v) <- ldapData, k == ldapUserMatriculation ]
+    userEmail'          = fold [ v | (k, v) <- ldapData, k == ldapUserEmail         ]
+    userDisplayName'    = fold [ v | (k, v) <- ldapData, k == ldapUserDisplayName   ]
+    userFirstName'      = fold [ v | (k, v) <- ldapData, k == ldapUserFirstName     ]
+    userSurname'        = fold [ v | (k, v) <- ldapData, k == ldapUserSurname       ]
+    userTitle'          = fold [ v | (k, v) <- ldapData, k == ldapUserTitle         ]
+
+    userAuthentication
+      | isPWHash  = error "PWHash should only work for users that are already known"
+      | otherwise = AuthLDAP
+    userLastAuthentication = now <$ guard (not isDummy)
+
+  userEmail <- if
+    | [bs] <- userEmail'
+    , Right userEmail <- Text.decodeUtf8' bs
+      -> return $ mk userEmail
+    | otherwise
+      -> throwM CampusUserInvalidEmail
+  userDisplayName <- if
+    | [bs] <- userDisplayName'
+    , Right userDisplayName <- Text.decodeUtf8' bs
+      -> return userDisplayName
+    | otherwise
+      -> throwM CampusUserInvalidDisplayName
+  userFirstName <- if
+    | [bs] <- userFirstName'
+    , Right userFirstName <- Text.decodeUtf8' bs
+      -> return userFirstName
+    | otherwise
+      -> throwM CampusUserInvalidGivenName
+  userSurname <- if
+    | [bs] <- userSurname'
+    , Right userSurname <- Text.decodeUtf8' bs
+      -> return userSurname
+    | otherwise
+      -> throwM CampusUserInvalidSurname
+  userTitle <- if
+    | all ByteString.null userTitle'
+      -> return Nothing
+    | [bs] <- userTitle'
+    , Right userTitle <- Text.decodeUtf8' bs
+      -> return $ Just userTitle
+    | otherwise
+      -> throwM CampusUserInvalidTitle
+  userMatrikelnummer <- if
+    | [bs] <- userMatrikelnummer'
+    , Right userMatrikelnummer <- Text.decodeUtf8' bs
+      -> return $ Just userMatrikelnummer
+    | [] <- userMatrikelnummer'
+      -> return Nothing
+    | otherwise
+      -> throwM CampusUserInvalidMatriculation
+
+  let
+    newUser = User
+      { userIdent                = mk credsIdent
+      , userMaxFavourites        = userDefaultMaxFavourites
+      , userTheme                = userDefaultTheme
+      , userDateTimeFormat       = userDefaultDateTimeFormat
+      , userDateFormat           = userDefaultDateFormat
+      , userTimeFormat           = userDefaultTimeFormat
+      , userDownloadFiles        = userDefaultDownloadFiles
+      , userNotificationSettings = def
+      , userMailLanguages        = def
+      , userTokensIssuedAfter    = Nothing
+      , ..
+      }
+    userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
+                  , UserDisplayName        =. userDisplayName
+                  , UserSurname            =. userSurname
+                  , UserEmail              =. userEmail
+                  ] ++
+                  [ UserLastAuthentication =. Just now | not isDummy ]
+
+  user@(Entity userId _) <- upsertBy (UniqueAuthentication $ mk credsIdent) newUser userUpdate
+
+  let
+    userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
+    userStudyFeatures' = do
+      (k, v) <- ldapData
+      guard $ k == ldapUserStudyFeatures
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+    termNames = nubBy ((==) `on` mk) $ do
+      (k, v) <- ldapData
+      guard $ k == ldapUserFieldName
+      v' <- v
+      Right str <- return $ Text.decodeUtf8' v'
+      return str
+
+  fs <- either (throwM . CampusUserInvalidFeaturesOfStudy . unpack) return userStudyFeatures
+
+  let
+    studyTermCandidates = Set.fromList $ do
+      name <- termNames
+      StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
+      return (key, name)
+    studyTermCandidateIncidence
+      = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID") -- Should never happen
+      . UUID.fromByteString
+      . fromStrict
+      . (convert :: Digest (SHAKE128 128) -> ByteString)
+      . runIdentity
+      $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
+
+  [E.Value candidatesRecorded] <- E.select . return . E.exists . E.from $ \candidate ->
+    E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
+
+  unless candidatesRecorded $ do
+    let
+      studyTermCandidates' = do
+        (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
+        return StudyTermCandidate{..}
+    insertMany_ studyTermCandidates'
+
+  E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
+  forM_ fs $ \f@StudyFeatures{..} -> do
+    insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
+    insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
+    void $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
+
+  return user
+  where
+    insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
+    isDummy  = credsPlugin == "dummy"
+    isPWHash = credsPlugin == "PWHash"
+
+
 instance YesodAuth UniWorX where
     type AuthId UniWorX = UserId
 
@@ -2681,25 +2966,34 @@ instance YesodAuth UniWorX where
         isDummy = credsPlugin == "dummy"
         isPWHash = credsPlugin == "PWHash"
 
-        excHandlers
+        excRecovery res
           | isDummy || isPWHash
-          = [ C.Handler $ \err -> do
+          = do
-                addMessage Error (toHtml $ tshow (err :: CampusUserException))
+              case res of
-                $logErrorS "LDAP" $ tshow err
+                UserError   err -> addMessageI Error   err
-                acceptExisting
+                ServerError err -> addMessage  Error $ toHtml err
-            ]
+                _other          -> return ()
+              acceptExisting
           | otherwise
-          = [ C.Handler $ \case
+          = return res
-                CampusUserNoResult -> do
+
-                  $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
+        excHandlers =
-                  return . UserError $ IdentifierNotFound credsIdent
+          [ C.Handler $ \case
-                CampusUserAmbiguous -> do
+              CampusUserNoResult -> do
-                  $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
+                $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
-                  return . UserError $ IdentifierNotFound credsIdent
+                excRecovery . UserError $ IdentifierNotFound credsIdent
-                err -> do
+              CampusUserAmbiguous -> do
-                  $logErrorS "LDAP" $ tshow err
+                $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
-                  return $ ServerError "LDAP lookup failed"
+                excRecovery . UserError $ IdentifierNotFound credsIdent
-            ]
+              err -> do
+                $logErrorS "LDAP" $ tshow err
+                mr <- getMessageRender
+                excRecovery . ServerError $ mr MsgInternalLdapError
+          , C.Handler $ \(cExc :: CampusUserConversionException) -> do
+              $logErrorS "LDAP" $ tshow cExc
+              mr <- getMessageRender
+              excRecovery . ServerError $ mr cExc
+          ]
 
         acceptExisting = do
           res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
@@ -2712,122 +3006,13 @@ instance YesodAuth UniWorX where
       UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
 
       flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
-        Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
+        Just (ldapConf, ldapPool) -> do
-          ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra
+          let userCreds = Creds credsPlugin (original userIdent) credsExtra
+          ldapData <- campusUser ldapConf ldapPool userCreds
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-
+          Authenticated . entityKey <$> upsertCampusUser ldapData userCreds
-          let
+        Nothing
-            userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
+          -> acceptExisting
-            userEmail' = lookup (Attr "mail") ldapData
-            userDisplayName' = lookup (Attr "displayName") ldapData
-            userSurname' = lookup (Attr "sn") ldapData
-
-            userAuthentication
-              | isPWHash  = error "PWHash should only work for users that are already known"
-              | otherwise = AuthLDAP
-            userLastAuthentication = now <$ guard (not isDummy)
-
-          userEmail <- if
-            | Just [bs] <- userEmail'
-            , Right userEmail <- Text.decodeUtf8' bs
-              -> return $ mk userEmail
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user email"
-          userDisplayName <- if
-            | Just [bs] <- userDisplayName'
-            , Right userDisplayName <- Text.decodeUtf8' bs
-              -> return userDisplayName
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user name"
-          userSurname <- if
-            | Just [bs] <- userSurname'
-            , Right userSurname <- Text.decodeUtf8' bs
-              -> return userSurname
-            | otherwise
-              -> throwError $ ServerError "Could not retrieve user surname"
-          userMatrikelnummer <- if
-            | Just [bs] <- userMatrikelnummer'
-            , Right userMatrikelnummer <- Text.decodeUtf8' bs
-              -> return $ Just userMatrikelnummer
-            | Nothing <- userMatrikelnummer'
-              -> return Nothing
-            | otherwise
-              -> throwError $ ServerError "Could not decode user matriculation"
-
-          let
-            newUser = User
-              { userMaxFavourites        = userDefaultMaxFavourites
-              , userTheme                = userDefaultTheme
-              , userDateTimeFormat       = userDefaultDateTimeFormat
-              , userDateFormat           = userDefaultDateFormat
-              , userTimeFormat           = userDefaultTimeFormat
-              , userDownloadFiles        = userDefaultDownloadFiles
-              , userNotificationSettings = def
-              , userMailLanguages        = def
-              , userTokensIssuedAfter    = Nothing
-              , ..
-              }
-            userUpdate =  [ UserMatrikelnummer     =. userMatrikelnummer
-                          , UserDisplayName        =. userDisplayName
-                          , UserSurname            =. userSurname
-                          , UserEmail              =. userEmail
-                          ] ++
-                          [ UserLastAuthentication =. Just now | not isDummy ]
-
-          userId <- lift $ entityKey <$> upsertBy uAuth newUser userUpdate
-
-          let
-            userStudyFeatures = fmap concat . forM userStudyFeatures' $ parseStudyFeatures userId now
-            userStudyFeatures' = do
-              (k, v) <- ldapData
-              guard $ k == Attr "dfnEduPersonFeaturesOfStudy"
-              v' <- v
-              Right str <- return $ Text.decodeUtf8' v'
-              return str
-
-            termNames = nubBy ((==) `on` mk) $ do
-              (k, v) <- ldapData
-              guard $ k == Attr "dfnEduPersonFieldOfStudyString"
-              v' <- v
-              Right str <- return $ Text.decodeUtf8' v'
-              return str
-
-          fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures
-
-          let
-            studyTermCandidates = Set.fromList $ do
-              name <- termNames
-              StudyFeatures{ studyFeaturesField = StudyTermsKey' key } <- fs
-              return (key, name)
-            studyTermCandidateIncidence
-              = fromMaybe (error "Could not convert studyTermCandidateIncidence-Hash to UUID")
-              . UUID.fromByteString
-              . fromStrict
-              . (convert :: Digest (SHAKE128 128) -> ByteString)
-              . runIdentity
-              $ sourceList (toStrict . Binary.encode <$> Set.toList studyTermCandidates) $$ sinkHash
-
-          [E.Value candidatesRecorded] <- lift . E.select . return . E.exists . E.from $ \candidate ->
-            E.where_ $ candidate E.^. StudyTermCandidateIncidence E.==. E.val studyTermCandidateIncidence
-
-          unless candidatesRecorded $ do
-            let
-              studyTermCandidates' = do
-                (studyTermCandidateKey, studyTermCandidateName) <- Set.toList studyTermCandidates
-                return StudyTermCandidate{..}
-            lift $ insertMany_ studyTermCandidates'
-
-          lift $ E.updateWhere [StudyFeaturesUser ==. userId] [StudyFeaturesValid =. False]
-          forM_ fs $ \f@StudyFeatures{..} -> do
-            lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing
-            lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing
-            void . lift $ upsert f [StudyFeaturesUpdated =. now, StudyFeaturesValid =. True]
-
-          return $ Authenticated userId
-        Nothing -> acceptExisting
-
-      where
-        insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
 
     authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
       [ campusLogin <$> appLdapConf <*> appLdapPool
@@ -2837,6 +3022,12 @@ instance YesodAuth UniWorX where
 
     authHttpManager = Yesod.getHttpManager
 
+    onLogin = addMessageI Success Auth.NowLoggedIn
+
+    onErrorHtml dest msg = do
+      addMessage Error $ toHtml msg
+      redirect dest
+
     renderAuthMessage _ _ = Auth.germanMessage -- TODO
 
 instance YesodAuthPersist UniWorX

src/Handler/Admin.hs

@@ -113,7 +113,7 @@ postAdminTestR = do
   formResultModal emailResult AdminTestR $ \(email, ls) -> do
     jId <- mapWriterT runDB $ do
       jId <- queueJob $ JobSendTestEmail email ls
-      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
+      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|] (Just IconEmail)
       return jId
     writeJobCtl $ JobCtlPerform jId
     addMessage Warning [shamlet|Inkorrekt ausgegebener Alert|] -- For testing alert handling when short circuiting; for proper (not fallback-solution) handling always use `tell` within `formResultModal`

src/Handler/Course/Communication.hs

@@ -0,0 +1,71 @@
+module Handler.Course.Communication
+  ( postCCommR, getCCommR
+  ) where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Communication
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+
+
+getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCCommR = postCCommR
+postCCommR tid ssh csh = do
+  jSender <- requireAuthId
+  cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+
+  commR CommunicationRoute
+    { crHeading    = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
+    , crUltDest    = SomeRoute $ CourseR tid ssh csh CCommR
+    , crJobs       = \Communication{..} -> do
+        let jSubject = cSubject
+            jMailContent = cBody
+            jCourse = cid
+            allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
+        jMailObjectUUID <- liftIO getRandom
+        jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
+          Left email -> return . Address Nothing $ CI.original email
+          Right rid  -> userAddress <$> getJust rid
+        forM_ allRecipients $ \jRecipientEmail ->
+          yield JobSendCourseCommunication{..}
+    , crRecipients = Map.fromList
+      [ ( RGCourseParticipants
+        , E.from $ \(user `E.InnerJoin` participant) -> do
+            E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
+            E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+            return user
+        )
+      , ( RGCourseLecturers
+        , E.from $ \(user `E.InnerJoin` lecturer) -> do
+            E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+            E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+            return user
+        )
+      , ( RGCourseCorrectors
+        , E.from $ \user -> do
+            E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
+              E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
+              E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+                   E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
+            return user
+        )
+      , ( RGCourseTutors
+        , E.from $ \user -> do
+            E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
+              E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
+              E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+                   E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
+            return user
+        )
+      ]
+    , crRecipientAuth = Just $ \uid -> do
+        cID <- encrypt uid
+        evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
+    }

src/Handler/Course/Delete.hs

@@ -0,0 +1,20 @@
+module Handler.Course.Delete
+  ( getCDeleteR, postCDeleteR
+  ) where
+
+import Import
+
+import Handler.Utils.Course
+import Handler.Utils.Delete
+
+import qualified Data.Set as Set
+
+
+getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCDeleteR = postCDeleteR
+postCDeleteR tid ssh csh = do
+  Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  deleteR $ (courseDeleteRoute $ Set.singleton cId)
+    { drAbort = SomeRoute $ CourseR tid ssh csh CShowR
+    , drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
+    }

src/Handler/Course/Edit.hs

@@ -0,0 +1,559 @@
+module Handler.Course.Edit
+  ( getCourseNewR, postCourseNewR
+  , getCEditR, postCEditR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+import Handler.Utils
+import Handler.Utils.Invitations
+
+import qualified Data.CaseInsensitive as CI
+import Data.Function ((&))
+
+import Data.Maybe (fromJust)
+import qualified Data.Set as Set
+import Data.Map ((!))
+import qualified Data.Map as Map
+
+import Control.Monad.Trans.Writer (execWriterT)
+
+import qualified Database.Esqueleto as E
+
+import Jobs.Queue
+
+import Handler.Course.LecturerInvite
+
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import qualified Data.Conduit.List as C
+
+
+data CourseForm = CourseForm
+        { cfCourseId    :: Maybe CourseId
+        , cfName        :: CourseName
+        , cfShort       :: CourseShorthand
+        , cfSchool      :: SchoolId
+        , cfTerm        :: TermId
+        , cfDesc        :: Maybe Html
+        , cfLink        :: Maybe Text
+        , cfMatFree     :: Bool
+        , cfAllocation  :: Maybe AllocationCourseForm
+        , cfCapacity    :: Maybe Int
+        , cfSecret      :: Maybe Text
+        , cfRegFrom     :: Maybe UTCTime
+        , cfRegTo       :: Maybe UTCTime
+        , cfDeRegUntil  :: Maybe UTCTime
+        , cfLecturers   :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        }
+
+data AllocationCourseForm = AllocationCourseForm
+  { acfAllocation                :: AllocationId
+  , acfInstructions              :: Maybe Html
+  , acfFiles                     :: Maybe (Source Handler (Either FileId File))
+  , acfApplicationText           :: Bool
+  , acfApplicationFiles          :: UploadMode
+  , acfApplicationRatingsVisible :: Bool
+  , acfMinCapacity               :: Int
+  }
+
+courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> Maybe (Entity AllocationCourse) -> CourseForm
+courseToForm (Entity cid Course{..}) lecs lecInvites alloc = CourseForm
+    { cfCourseId   = Just cid
+    , cfName       = courseName
+    , cfDesc       = courseDescription
+    , cfLink       = courseLinkExternal
+    , cfShort      = courseShorthand
+    , cfTerm       = courseTerm
+    , cfSchool     = courseSchool
+    , cfCapacity   = courseCapacity
+    , cfSecret     = courseRegisterSecret
+    , cfMatFree    = courseMaterialFree
+    , cfRegFrom    = courseRegisterFrom
+    , cfRegTo      = courseRegisterTo
+    , cfDeRegUntil = courseDeregisterUntil
+    , cfAllocation = allocationCourseToForm <$> alloc
+    , cfLecturers  = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
+                  ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
+    }
+
+allocationCourseToForm :: Entity AllocationCourse -> AllocationCourseForm
+allocationCourseToForm (Entity _ AllocationCourse{..}) = AllocationCourseForm
+  { acfAllocation = allocationCourseAllocation
+  , acfMinCapacity = allocationCourseMinCapacity
+  , acfInstructions = allocationCourseInstructions
+  , acfFiles = Nothing
+  , acfApplicationText = allocationCourseApplicationText
+  , acfApplicationFiles = allocationCourseApplicationFiles
+  , acfApplicationRatingsVisible = allocationCourseRatingsVisible
+  }
+
+makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
+makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
+    -- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
+    -- let editCid = cfCourseId =<< template -- possible start for refactoring
+
+    MsgRenderer mr <- getMsgRenderer
+
+    uid <- liftHandlerT requireAuthId
+    (lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
+      <$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
+      <*> (map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. uid] [] )
+    let userSchools = lecSchools ++ admSchools
+
+    termsField <- case template of
+          -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
+          (Just cform)  | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
+              _courseOld@Course{..} <- runDB $ get404 cid
+              mayEditTerm <- isAuthorized TermEditR True
+              mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
+              return $ if
+                | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
+                | otherwise ->  termsSetField [cfTerm cform]
+          _allOtherCases -> return termsAllowedField
+
+    let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
+        miAdd _ _ nudge btn = Just $ \csrf -> do
+          (addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
+          addRes'  <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
+          let addRes'' = case (,) <$> addRes <*> addRes' of
+                FormSuccess (CI.mk -> email, mLid) ->
+                  let new = maybe (Left email) Right mLid
+                  in  FormSuccess $ \prev -> if
+                        | new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
+                        | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
+                FormFailure errs -> FormFailure errs
+                FormMissing -> FormMissing
+              addView' = $(widgetFile "course/lecturerMassInput/add")
+          return (addRes'', addView')
+
+        miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
+        miCell _ (Right lid) defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
+          User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
+          return (Just <$> lrwRes,lrwView')
+        miCell _ (Left lEmail) defType nudge = \csrf -> do
+          (lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
+          let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
+          return (lrwRes,lrwView')
+
+        miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
+                 -> ListPosition -- ^ Coordinate to delete
+                 -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
+        miDelete = miDeleteList
+
+        miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
+        miAllowAdd _ _ _ = True
+
+        miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
+        miAddEmpty _ _ _ = Set.empty
+
+        miLayout :: ListLength
+                 -> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
+                 -> Map ListPosition Widget -- ^ Cell widgets
+                 -> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
+                 -> Map (Natural, ListPosition) Widget -- ^ Addition widgets
+                 -> Widget
+        miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
+
+        miIdent :: Text
+        miIdent = "lecturers"
+
+
+        lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
+        lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
+                MassInput{..}
+                (fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
+                True
+                (Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
+                mempty
+          where
+            liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
+            liftEither (Right lid  , Just lType) = Right (lid   , lType )
+            liftEither (Left lEmail, mLType    ) = Left  (lEmail, mLType)
+            liftEither _                         = error "liftEither: lecturerForm produced output it should not have been able to"
+
+            unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
+            unliftEither (Right (lid   , lType )) = (Right lid  , Just lType)
+            unliftEither (Left  (lEmail, mLType)) = (Left lEmail, mLType    )
+
+    (newRegFrom,newRegTo,newDeRegUntil) <- case template of
+        (Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
+        _allIOtherCases -> do
+            mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
+            return ( (Just . toMidnight     . termStart . entityVal) <$> mbLastTerm
+                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm
+                   , (Just . beforeMidnight . termEnd   . entityVal) <$> mbLastTerm )
+
+    let
+      allocationForm :: AForm Handler (Maybe AllocationCourseForm)
+      allocationForm = wFormToAForm $ do
+        availableAllocations' <- liftHandlerT . runDB . E.select . E.from $ \(allocation `E.InnerJoin` term) -> do
+          E.on $ allocation E.^. AllocationTerm E.==. term E.^. TermId
+          E.where_ $ term E.^. TermActive
+          return allocation
+
+        now <- liftIO getCurrentTime
+        let
+          allocationEnabled :: Entity Allocation -> Bool
+          allocationEnabled (Entity _ Allocation{..}) = NTop allocationStaffRegisterFrom <= NTop (Just now)
+                                                     && NTop (Just now) <= NTop allocationStaffRegisterTo
+          availableAllocations = filter allocationEnabled availableAllocations'
+
+          mkAllocationOption :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Allocation -> m (Option AllocationId)
+          mkAllocationOption (Entity aId Allocation{..}) = liftHandlerT $ do
+            cID <- encrypt aId :: Handler CryptoUUIDAllocation
+            return . Option (mr . MsgCourseAllocationOption (mr . ShortTermIdentifier $ unTermKey allocationTerm) $ CI.original allocationName) aId $ toPathPiece cID
+
+        case availableAllocations of
+          [] -> wforced (convertField (const Nothing) (const False) checkBoxField) (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseNoAllocationsAvailable) Nothing
+          _  -> do
+            allocationOptions <- mkOptionList <$> mapM mkAllocationOption availableAllocations
+
+            oldFileIds <- for ((,) <$> (fmap acfAllocation $ template >>= cfAllocation) <*> (template >>= cfCourseId)) $ \(allId, cId) -> fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select . E.from $ \(allocationCourseFile `E.InnerJoin` allocationCourse) -> do
+              E.on $ allocationCourseFile E.^. AllocationCourseFileAllocationCourse E.==. allocationCourse E.^. AllocationCourseId
+              E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cId
+                   E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allId
+              return $ allocationCourseFile E.^. AllocationCourseFileFile
+              
+
+            let
+              allocationForm' = AllocationCourseForm
+                <$> apreq (selectField' Nothing $ return allocationOptions) (fslI MsgCourseAllocation) (fmap acfAllocation $ template >>= cfAllocation)
+                <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslI MsgCourseAllocationInstructions & setTooltip MsgCourseAllocationInstructionsTip) (fmap acfInstructions $ template >>= cfAllocation))
+                <*> aopt (multiFileField . return $ fromMaybe Set.empty oldFileIds) (fslI MsgCourseAllocationApplicationTemplate) (fmap acfFiles $ template >>= cfAllocation)
+                <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationText & setTooltip MsgCourseAllocationApplicationTextTip) (fmap acfApplicationText $ template >>= cfAllocation)
+                <*> uploadModeForm (fmap acfApplicationFiles $ template >>= cfAllocation)
+                <*> apopt checkBoxField (fslI MsgCourseAllocationApplicationRatingsVisible & setTooltip MsgCourseAllocationApplicationRatingsVisibleTip) (fmap acfApplicationRatingsVisible $ template >>= cfAllocation)
+                <*> apreq (natFieldI MsgCourseAllocationMinCapacityMustBeNonNegative) (fslI MsgCourseAllocationMinCapacity & setTooltip MsgCourseAllocationMinCapacityTip) (fmap acfMinCapacity $ template >>= cfAllocation)
+            
+            optionalActionW allocationForm' (fslI MsgCourseAllocationParticipate & setTooltip MsgCourseAllocationParticipateTip) (is _Just . cfAllocation <$> template)
+
+    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
+      <$> pure (cfCourseId =<< template)
+      <*> areq ciField (fslI MsgCourseName)                             (cfName       <$> template)
+      <*> areq ciField (fslI MsgCourseShorthand
+            -- & addAttr "disabled" "disabled"
+            & setTooltip MsgCourseShorthandUnique)                      (cfShort      <$> template)
+      <*> areq (schoolFieldFor userSchools)   (fslI MsgCourseSchool)    (cfSchool     <$> template)
+      <*> areq termsField                     (fslI MsgCourseSemester)  (cfTerm       <$> template)
+      <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
+                         & setTooltip MsgCourseDescriptionTip)          (cfDesc       <$> template)
+      <*> aopt urlField  (fslpI MsgCourseHomepageExternal "Optionale externe URL")
+                                                                        (cfLink       <$> template)
+      <*> apopt checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree    <$> template)
+      <*  aformSection MsgCourseFormSectionRegistration
+      <*> allocationForm
+      <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
+            & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
+      <*> aopt textField      (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
+            & setTooltip MsgCourseSecretTip)                            (cfSecret     <$> template)
+      <*> aopt utcTimeField   (fslpI MsgRegisterFrom (mr MsgDate)
+            & setTooltip MsgCourseRegisterFromTip)                      (deepAlt (cfRegFrom    <$> template) newRegFrom)
+      <*> aopt utcTimeField   (fslpI MsgRegisterTo   (mr MsgDate)
+            & setTooltip MsgCourseRegisterToTip)                        (deepAlt (cfRegTo      <$> template) newRegTo)
+      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   (mr MsgDate)
+            & setTooltip MsgCourseDeregisterUntilTip)                   (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
+      <*  aformSection MsgCourseFormSectionAdministration
+      <*> lecturerForm
+    errorMsgs' <- traverse validateCourse result
+    return $ case errorMsgs' of
+      FormSuccess errorMsgs
+        | not $ null errorMsgs ->
+          (FormFailure errorMsgs,
+                [whamlet|
+                  <div class="alert alert-danger">
+                    <div class="alert__content">
+                      <h4> Fehler:
+                      <ul>
+                        $forall errmsg <- errorMsgs
+                          <li> #{errmsg}
+                  ^{widget}
+                |]
+              )
+      _ -> (result, widget)
+
+
+validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
+validateCourse CourseForm{..} = do
+  now <- liftIO getCurrentTime
+  uid <- liftHandlerT requireAuthId
+  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
+  MsgRenderer mr <- getMsgRenderer
+  allocationTerm <- for (acfAllocation <$> cfAllocation) $ fmap allocationTerm . liftHandlerT . runDB . getJust
+
+  oldAllocatedCapacity <- fmap join . for cfCourseId $ \cid -> liftHandlerT . runDB $ do
+    prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
+    prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
+
+    fmap join . for prevAllocation $ \Allocation{allocationStaffRegisterTo} -> if
+      | is _Just userAdmin
+        -> return Nothing
+      | NTop allocationStaffRegisterTo <= NTop (Just now)
+        -> Just . courseCapacity <$> getJust cid
+      | otherwise
+        -> return Nothing
+
+
+  return
+    [ mr msg | (False, msg) <-
+        [
+          ( NTop cfRegFrom <= NTop cfRegTo
+          , MsgCourseRegistrationEndMustBeAfterStart
+          )
+        ,
+          ( NTop cfRegFrom <= NTop cfDeRegUntil
+          , MsgCourseDeregistrationEndMustBeAfterStart
+          )
+        , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
+          , MsgCourseUserMustBeLecturer
+          )
+        , ( is _Nothing cfAllocation || is _Just cfCapacity
+          , MsgCourseAllocationRequiresCapacity
+          )
+        , ( maybe True (== cfTerm) allocationTerm
+          , MsgCourseAllocationTermMustMatch
+          )
+        , ( maybe True (== cfCapacity) oldAllocatedCapacity
+          , MsgCourseAllocationCapacityMayNotBeChanged
+          )
+        ] ]
+  
+
+getCourseNewR :: Handler Html -- call via toTextUrl
+getCourseNewR = do
+  uid <- requireAuthId
+  params <- runInputGetResult $ (,,)    --TODO: change to AForm, which is used in Course-Copy-Button
+            <$> iopt termNewField "tid"
+            <*> iopt ciField      "ssh"
+            <*> iopt ciField      "csh"
+
+  let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
+      getParams = concat
+        [ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
+        , [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
+        , [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
+        ]
+
+  let noTemplateAction = courseEditHandler' Nothing
+  case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
+    FormMissing      -> noTemplateAction
+    FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
+                        noTemplateAction
+    FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
+    FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
+      oldCourses <- runDB $
+        E.select $ E.from $ \course -> do
+          whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+          whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+          whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
+          let lecturersCourse =
+                E.exists $ E.from $ \lecturer ->
+                  E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
+                      E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+          let lecturersSchool =
+                E.exists $ E.from $ \user ->
+                  E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                      E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+          let courseCreated c =
+                E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+                  E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+                  return $ E.min_ $ edit E.^. CourseEditTime
+          E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
+                    , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
+                    , E.desc $ courseCreated course]                                     -- most recent created course
+          E.limit 1
+          return course
+      template <- case listToMaybe oldCourses of
+        (Just oldTemplate) ->
+            let newTemplate = courseToForm oldTemplate [] [] Nothing in
+            return $ Just $ newTemplate
+                { cfCourseId   = Nothing
+                , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
+                , cfRegFrom    = Nothing
+                , cfRegTo      = Nothing
+                , cfDeRegUntil = Nothing
+                }
+        Nothing -> do
+            (tidOk,sshOk,cshOk) <- runDB $ (,,)
+                <$> ifMaybeM mbTid True existsKey
+                <*> ifMaybeM mbSsh True existsKey
+                <*> ifMaybeM mbCsh True (\csh -> not . null <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+            unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+            unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+            unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
+            when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
+            return Nothing
+      courseEditHandler' template
+
+postCourseNewR :: Handler Html
+postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.
+
+getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCEditR  = pgCEditR
+postCEditR = pgCEditR
+
+pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+pgCEditR tid ssh csh = do
+  courseData <- runDB $ do
+      mbCourse     <- getBy (TermSchoolCourseShort tid ssh csh)
+      mbLecs       <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
+      mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
+      mbAllocation <- for mbCourse $ \course -> getBy . UniqueAllocationCourse $ entityKey course
+      return $ (,,,) <$> mbCourse <*> mbLecs <*> mbLecInvites <*> mbAllocation
+  -- IMPORTANT: both GET and POST Handler must use the same template,
+  --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
+  courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 4) courseToForm <$> courseData
+
+
+-- | Course Creation and Editing
+-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
+-- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
+courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
+courseEditHandler miButtonAction mbCourseForm = do
+    aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
+    ((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
+    formResult result $ \case
+      res@CourseForm
+        { cfCourseId = Nothing
+        , cfShort    = csh
+        , cfSchool   = ssh
+        , cfTerm     = tid
+        } -> do -- create new course
+          now <- liftIO getCurrentTime
+          insertOkay <- runDBJobs $ do
+            insertOkay <- insertUnique Course
+              { courseName            = cfName     res
+              , courseDescription     = cfDesc     res
+              , courseLinkExternal    = cfLink     res
+              , courseShorthand       = cfShort    res
+              , courseTerm            = cfTerm     res
+              , courseSchool          = cfSchool   res
+              , courseCapacity        = cfCapacity res
+              , courseRegisterSecret  = cfSecret   res
+              , courseMaterialFree    = cfMatFree  res
+              , courseRegisterFrom    = cfRegFrom  res
+              , courseRegisterTo      = cfRegTo    res
+              , courseDeregisterUntil = cfDeRegUntil res
+              }
+            whenIsJust insertOkay $ \cid -> do
+              let (invites, adds) = partitionEithers $ cfLecturers res
+              insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
+              sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
+              insert_ $ CourseEdit aid now cid
+              upsertAllocationCourse cid $ cfAllocation res
+            return insertOkay
+          case insertOkay of
+            Just _ -> do
+              -- addMessageI Info $ MsgCourseNewOk tid ssh csh
+              redirect $ CourseR tid ssh csh CShowR
+            Nothing ->
+              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
+
+      res@CourseForm
+        { cfCourseId = Just cid
+        , cfShort    = csh
+        , cfSchool   = ssh
+        , cfTerm     = tid
+        } -> do -- edit existing course
+          now <- liftIO getCurrentTime
+          -- addMessage "debug" [shamlet| #{show res}|]
+          success <- runDBJobs $ do
+            old <- get cid
+            case old of
+              Nothing -> addMessageI Error MsgInvalidInput $> False
+              (Just _) -> do
+                updOkay <- myReplaceUnique cid Course
+                  { courseName            = cfName       res
+                  , courseDescription     = cfDesc       res
+                  , courseLinkExternal    = cfLink       res
+                  , courseShorthand       = cfShort      res
+                  , courseTerm            = cfTerm       res -- dangerous
+                  , courseSchool          = cfSchool     res
+                  , courseCapacity        = cfCapacity   res
+                  , courseRegisterSecret  = cfSecret     res
+                  , courseMaterialFree    = cfMatFree    res
+                  , courseRegisterFrom    = cfRegFrom    res
+                  , courseRegisterTo      = cfRegTo      res
+                  , courseDeregisterUntil = cfDeRegUntil res
+                  }
+                case updOkay of
+                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
+                  Nothing  -> do
+                    deleteWhere [LecturerCourse ==. cid]
+                    deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
+                    let (invites, adds) = partitionEithers $ cfLecturers res
+                    insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
+                    sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
+
+                    insert_ $ CourseEdit aid now cid
+                    upsertAllocationCourse cid $ cfAllocation res
+                    addMessageI Success $ MsgCourseEditOk tid ssh csh
+                    return True
+          when success $ redirect $ CourseR tid ssh csh CShowR
+    actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
+    defaultLayout $ do
+      setTitleI MsgCourseEditTitle
+      wrapForm formWidget def
+        { formAction = Just $ SomeRoute actionUrl
+        , formEncoding = formEnctype
+        }
+
+upsertAllocationCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe AllocationCourseForm -> ReaderT SqlBackend m ()
+upsertAllocationCourse cid cfAllocation = do
+  now <- liftIO getCurrentTime
+  uid <- liftHandlerT requireAuthId
+  Course{..} <- getJust cid
+  prevAllocationCourse <- getBy $ UniqueAllocationCourse cid
+  prevAllocation <- fmap join . traverse get $ allocationCourseAllocation . entityVal <$> prevAllocationCourse
+  userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid courseSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
+
+  doEdit <- if
+    | is _Just userAdmin
+      -> return True
+    | Just Allocation{allocationStaffRegisterTo} <- prevAllocation
+    , NTop allocationStaffRegisterTo <= NTop (Just now)
+      -> False <$ addMessageI Error MsgAllocationStaffRegisterToExpired
+    | otherwise
+      -> return True
+
+  when doEdit $
+    case cfAllocation of
+      Just AllocationCourseForm{..} -> do
+        Entity acId _ <- upsert AllocationCourse
+          { allocationCourseAllocation       = acfAllocation
+          , allocationCourseCourse           = cid
+          , allocationCourseMinCapacity      = acfMinCapacity
+          , allocationCourseInstructions     = acfInstructions
+          , allocationCourseApplicationText  = acfApplicationText
+          , allocationCourseApplicationFiles = acfApplicationFiles
+          , allocationCourseRatingsVisible   = acfApplicationRatingsVisible
+          }
+          [ AllocationCourseAllocation       =. acfAllocation
+          , AllocationCourseCourse           =. cid
+          , AllocationCourseMinCapacity      =. acfMinCapacity
+          , AllocationCourseInstructions     =. acfInstructions
+          , AllocationCourseApplicationText  =. acfApplicationText
+          , AllocationCourseApplicationFiles =. acfApplicationFiles
+          , AllocationCourseRatingsVisible   =. acfApplicationRatingsVisible
+          ]
+
+        let
+          finsert val = do
+            fId <- lift $ either return insert val
+            tell $ Set.singleton fId
+            lift $
+              void . insertUnique $ AllocationCourseFile acId fId
+        keep <- execWriterT . runConduit $ transPipe liftHandlerT (traverse_ id acfFiles) .| C.mapM_ finsert
+        acfs <- selectList [ AllocationCourseFileAllocationCourse ==. acId, AllocationCourseFileFile /<-. Set.toList keep ] []
+        mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+      Nothing
+        | Just (Entity prevId _) <- prevAllocationCourse
+          -> do
+            acfs <- selectList [ AllocationCourseFileAllocationCourse ==. prevId ] []
+            mapM_ deleteCascade $ map (allocationCourseFileFile . entityVal) acfs
+            delete prevId
+      _other -> return ()

src/Handler/Course/LecturerInvite.hs

@@ -0,0 +1,86 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Course.LecturerInvite
+  ( lecturerInvitationConfig
+  , getCLecInviteR, postCLecInviteR
+  , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+import Handler.Utils.Invitations
+
+import qualified Data.CaseInsensitive as CI
+import Data.Function ((&))
+
+import Data.Aeson hiding (Result(..))
+
+import Text.Hamlet (ihamlet)
+
+
+instance IsInvitableJunction Lecturer where
+  type InvitationFor Lecturer = Course
+  data InvitableJunction Lecturer = JunctionLecturer
+    { jLecturerType :: LecturerType
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData Lecturer = InvDBDataLecturer
+    { invDBLecturerType :: Maybe LecturerType
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData Lecturer = InvTokenDataLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
+    (\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
+
+instance ToJSON (InvitableJunction Lecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData Lecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData Lecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData Lecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+lecturerInvitationConfig :: InvitationConfig Lecturer
+lecturerInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
+    invitationResolveFor _ = do
+      Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
+      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+    invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
+    invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
+      Nothing    -> areq    (selectField optionsFinite) lFs Nothing
+      Just lType -> aforced (selectField optionsFinite) lFs lType
+      where
+        toJunction jLecturerType = (JunctionLecturer{..}, ())
+        lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
+      MsgRenderer mr <- getMsgRenderer
+      return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
+    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+
+getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCLecInviteR = postCLecInviteR
+postCLecInviteR = invitationR lecturerInvitationConfig
+

src/Handler/Course/List.hs

@@ -0,0 +1,199 @@
+module Handler.Course.List
+  ( makeCourseTable
+  , getCourseListR
+  , getTermCurrentR
+  , getTermSchoolCourseListR
+  , getTermCourseListR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+-- import Utils.DB
+import Handler.Utils
+import Handler.Utils.Table.Cells
+
+import Data.Function ((&))
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+
+-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
+type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User])
+
+colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
+            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
+              [whamlet|_{courseName}|]
+
+colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colDescription = sortable Nothing mempty
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
+            case courseDescription of
+              Nothing      -> mempty
+              (Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
+
+colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
+            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
+
+colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } ->
+            anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
+
+colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _) } ->
+            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
+
+colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
+          $ \DBRow{ dbrOutput=(_, _, registered, _, _) } -> tickmarkCell registered
+
+type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
+
+course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
+course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
+    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+    return (E.countRows :: E.SqlExpr (E.Value Int))
+
+course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
+course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
+    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+      E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
+
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
+makeCourseTable whereClause colChoices psValidator = do
+  muid <- lift maybeAuthId
+  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
+      dbtSQLQuery qin@(course `E.InnerJoin` school) = do
+        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+        let participants = course2Participants qin
+        let registered   = course2Registered muid qin
+        E.where_ $ whereClause (course, participants, registered)
+        return (course, participants, registered, school)
+      lecturerQuery cid (user `E.InnerJoin` lecturer) = do
+        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+        E.where_ $ cid E.==. lecturer E.^. LecturerCourse
+        return user
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
+      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> do
+        lecturerList <- lift $ E.select $ E.from $ lecturerQuery $ E.val $ entityKey course
+        return (course, participants, registered, school, lecturerList)
+  snd <$> dbTable psValidator DBTable
+    { dbtSQLQuery
+    , dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
+    , dbtColonnade = colChoices
+    , dbtProj
+    , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
+        [ ( "course",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
+        , ( "cshort",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
+        , ( "term"  ,        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
+        , ( "school",        SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
+        , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
+        , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
+        , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
+        , ( "members",       SortColumn   course2Participants   )
+        , ( "registered",    SortColumn $ course2Registered muid)
+        ]
+    , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
+        [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "term"  , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
+          )
+--         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+--                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+--                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
+--           )
+        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
+              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
+          )
+        , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "lecturer", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> E.exists $ E.from $ \t -> do
+                  user <- lecturerQuery (course E.^. CourseId) t
+                  E.where_ $ E.any (E.hasInfix (user E.^. UserSurname) . E.val) (criterias :: Set.Set Text)
+          )
+        , ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> course2Registered muid tExpr E.==. E.val needle
+          )
+        , ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
+              Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
+              Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+                       E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
+          )
+        ]
+    , dbtFilterUI = \mPrev -> mconcat $ catMaybes
+      [ Just  $ prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTerm)
+      , Just  $ prismAForm (singletonFilter "schoolshort" . maybePrism (_PathPiece . from _SchoolId)) mPrev $ aopt (hoistField lift schoolField) (fslI MsgCourseSchool)
+      , Just  $ prismAForm (singletonFilter "lecturer") mPrev $ aopt textField (fslI MsgCourseLecturer)
+      , Just  $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch)
+      , muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
+      ]
+    , dbtStyle = def
+      { dbsFilterLayout = defaultDBSFilterLayout
+      , dbsTemplate = DBSTCourse (_dbrOutput . _1) (_dbrOutput . _5) (_dbrOutput . _3) (_dbrOutput . _4)
+      --                             ^ course          ^ lecturer list   ^ isRegistered    ^ school
+      }
+    , dbtParams = def
+    , dbtIdent = "courses" :: Text
+    , dbtCsvEncode = noCsvEncode
+    , dbtCsvDecode = Nothing
+    }
+
+getCourseListR :: Handler Html
+getCourseListR = do
+  muid <- maybeAuthId
+  let colonnade = widgetColonnade $ mconcat
+        [ colCourse -- colCourseDescr
+        , colDescription
+        , colSchoolShort
+        , colTerm
+        , colCShort
+        , maybe mempty (const colRegistered) muid
+        ]
+      whereClause = const $ E.val True
+      validator = def
+        & defaultSorting [SortDescBy "term",SortAscBy "course"]
+  coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
+  defaultLayout $ do
+    setTitleI MsgCourseListTitle
+    $(widgetFile "courses")
+
+getTermCurrentR :: Handler Html
+getTermCurrentR = do
+  termIds  <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
+  case fromNullable termIds of
+    Nothing -> notFound
+    (Just (maximum -> tid)) ->
+        redirect $ (CourseListR, [("courses-term", toPathPiece tid)])  -- redirect avoids problematic breadcrumbs, headings, etc.
+
+getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
+getTermSchoolCourseListR tid ssh = redirect $ (CourseListR, [("courses-term", toPathPiece tid), ("courses-schoolshort", toPathPiece ssh)])
+
+
+getTermCourseListR :: TermId -> Handler Html
+getTermCourseListR tid = redirect $ (CourseListR, [("courses-term", toPathPiece tid)])

src/Handler/Course/ParticipantInvite.hs

@@ -0,0 +1,176 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Course.ParticipantInvite
+  ( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
+  , getCInviteR, postCInviteR
+  , getCAddUserR, postCAddUserR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+import Handler.Utils
+import Handler.Utils.Invitations
+
+import qualified Data.CaseInsensitive as CI
+import Data.Function ((&))
+
+import qualified Data.Set as Set
+
+import Jobs.Queue
+
+import Data.Aeson hiding (Result(..))
+
+import Text.Hamlet (ihamlet)
+
+import Control.Monad.Trans.Writer (WriterT, execWriterT)
+import Control.Monad.Except (MonadError(..))
+
+import Generics.Deriving.Monoid (memptydefault, mappenddefault)
+
+
+-- Invitations for ordinary participants of this course
+instance IsInvitableJunction CourseParticipant where
+  type InvitationFor CourseParticipant = Course
+  data InvitableJunction CourseParticipant = JunctionParticipant
+    { jParticipantRegistration :: UTCTime
+    , jParticipantField        :: Maybe StudyFeaturesId
+    , jParticipantAllocated    :: Bool
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData CourseParticipant = InvDBDataParticipant
+    -- no data needed in DB to manage participant invitation
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData CourseParticipant = InvTokenDataParticipant
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated))
+    (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField courseParticipantAllocated) -> CourseParticipant{..})
+
+instance ToJSON (InvitableJunction CourseParticipant) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction CourseParticipant) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData CourseParticipant) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData CourseParticipant) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData CourseParticipant) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData CourseParticipant) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+participantInvitationConfig :: InvitationConfig CourseParticipant
+participantInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
+    invitationResolveFor _ = do
+      Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
+      getKeyBy404 $ TermSchoolCourseShort tid csh ssh
+    invitationSubject     (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
+    invitationHeading     (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
+    invitationExplanation _          _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
+      now <- liftIO getCurrentTime
+      studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
+          (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
+      return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ Course{..}) _ =
+      return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
+    invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
+
+data AddRecipientsResult = AddRecipientsResult
+  { aurAlreadyRegistered
+  , aurNoUniquePrimaryField
+  , aurSuccess              :: [UserEmail]
+  } deriving (Read, Show, Generic, Typeable)
+
+instance Monoid AddRecipientsResult where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCAddUserR = postCAddUserR
+postCAddUserR tid ssh csh = do
+    cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
+      enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
+      wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
+              (fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+
+    formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
+
+    let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
+
+    siteLayoutMsg heading $ do
+      setTitleI heading
+      wrapForm formWgt def
+        { formEncoding
+        , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
+        }
+  where
+    processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
+    processUsers cid users = do
+      let (emails,uids) = partitionEithers $ Set.toList users
+      AddRecipientsResult{..} <- lift . runDBJobs $ do
+        -- send Invitation eMails to unkown users
+        sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
+        -- register known users
+        execWriterT $ mapM (registerUser cid) uids
+
+      unless (null emails) $
+        tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
+
+      unless (null aurAlreadyRegistered) $ do
+        let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
+            modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
+        tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
+
+      unless (null aurNoUniquePrimaryField) $ do
+        let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
+            modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
+        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
+
+      unless (null aurSuccess) $
+        tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
+
+    registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
+    registerUser cid uid = exceptT tell tell $ do
+      User{..} <- lift . lift $ getJust uid
+
+      whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
+        throwError $ mempty { aurAlreadyRegistered = pure userEmail }
+
+      features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
+
+      let courseParticipantField
+            | [f] <- features = Just f
+            | otherwise       = Nothing
+
+      courseParticipantRegistration <- liftIO getCurrentTime
+      void . lift . lift . insert $ CourseParticipant
+        { courseParticipantCourse = cid
+        , courseParticipantUser = uid
+        , courseParticipantAllocated = False
+        , ..
+        }
+
+      return $ case courseParticipantField of
+        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
+        Just _  -> mempty { aurSuccess              = pure userEmail }
+
+
+getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCInviteR = postCInviteR
+postCInviteR = invitationR participantInvitationConfig

src/Handler/Course/Register.hs

@@ -0,0 +1,96 @@
+module Handler.Course.Register
+  ( ButtonCourseRegister(..)
+  , courseRegisterForm
+  , getCRegisterR, postCRegisterR
+  ) where
+
+import Import
+
+import Utils.Form
+import Handler.Utils
+
+import Data.Function ((&))
+
+
+-- Dedicated CourseRegistrationButton
+data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCourseRegister
+instance Finite ButtonCourseRegister
+nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonCourseRegister id
+instance Button UniWorX ButtonCourseRegister where
+  btnClasses BtnCourseRegister   = [BCIsButton, BCPrimary]
+  btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
+
+  btnLabel  BtnCourseRegister   = [whamlet|#{iconEnrol True}  _{MsgBtnCourseRegister}|]
+  btnLabel  BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
+
+ 
+-- | Registration button with maybe a userid if logged in
+-- , maybe existing features if already registered
+-- , maybe some default study features
+-- , maybe a course secret
+courseRegisterForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
+-- unfinished WIP: must take study features if registred and show as mforced field
+courseRegisterForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
+    -- secret fields
+    (msecretRes', msecretView) <- case msecret of
+      (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
+      _ -> return (Nothing,Nothing)
+    -- study features
+    (msfRes', msfView) <- case loggedin of
+      Nothing -> return (Nothing,Nothing)
+      Just _  -> bimap Just Just <$> case participant of
+        Just CourseParticipant{courseParticipantField=Just sfid}
+                -> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
+        _other  -> mreq    (studyFeaturesPrimaryFieldFor False [ ]    loggedin) (fslI MsgCourseStudyFeature
+                                                                 & setTooltip  MsgCourseStudyFeatureTooltip) (Just defSFid)
+    -- button de-/register
+    (btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister isRegistered) "buttonField ignores settings anyway" Nothing
+
+    let widget = $(widgetFile "widgets/register-form/register-form")
+    let msecretRes | Just res <- msecretRes' = Just <$> res
+                   | otherwise               = FormSuccess Nothing
+    let msfRes     | Just res <- msfRes'     = res
+                   | otherwise               = FormSuccess Nothing
+    -- checks that correct button was pressed, and ignores result of btnRes
+    let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
+    return (formRes, widget)
+  where
+    isRegistered = isJust participant
+
+
+-- | Workaround for klicking register button without being logged in.
+-- After log in, the user sees a "get request not supported" error.
+getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCRegisterR tid ssh csh = do
+  muid <- maybeAuthId
+  case muid of
+    Nothing -> addMessageI Info MsgLoginNecessary
+    (Just uid) -> runDB $ do
+      cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+      registration <- getBy (UniqueParticipant uid cid)
+      when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
+  redirect $ CourseR tid ssh csh CShowR
+
+postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+postCRegisterR tid ssh csh = do
+  aid <- requireAuthId
+  (cid, course, registration) <- runDB $ do
+      (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+      registration <- getBy (UniqueParticipant aid cid)
+      return (cid, course, entityVal <$> registration)
+  let isRegistered  = isJust registration
+  ((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course
+  formResult regResult $ \(mbSfId,codeOk) -> if
+      | isRegistered -> do
+          runDB $ deleteBy $ UniqueParticipant aid cid
+          addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
+      | codeOk -> do
+          actTime <- liftIO getCurrentTime
+          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId False
+          when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
+      | otherwise -> addMessageI Warning MsgCourseSecretWrong
+  -- addMessage Info $ toHtml $ show regResult -- For debugging only
+  redirect $ CourseR tid ssh csh CShowR

src/Handler/Course/Show.hs

@@ -0,0 +1,226 @@
+module Handler.Course.Show
+  ( getCShowR
+  ) where
+
+import Import
+
+import Utils.Form
+import Handler.Utils
+import Handler.Utils.Table.Cells
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+import qualified Data.CaseInsensitive as CI
+import Data.Function ((&))
+
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+
+import Handler.Course.Register
+
+
+getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCShowR tid ssh csh = do
+  mbAid <- maybeAuthId
+  (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors,mAllocation) <- runDB . maybeT notFound $ do
+    [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
+       <- lift . E.select . E.from $
+         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
+            E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
+                E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
+            E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
+                 E.&&. course E.^. CourseShorthand E.==. E.val csh
+            E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
+            let numParticipants = E.sub_select . E.from $ \part -> do
+                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
+                  return ( E.countRows :: E.SqlExpr (E.Value Int))
+            return (course,school E.^. SchoolName, numParticipants, participant)
+    defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
+    staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
+      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+      E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
+      return ( lecturer E.^. LecturerType
+             , user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
+    let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
+        partStaff (CourseLecturer  ,name,surn,mail) = Right (name,surn,mail)
+        partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
+        (assistants,lecturers) = partitionWith  partStaff $ map $(unValueN 4) staff
+    correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
+      E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+      E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
+      return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
+    tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
+      E.on $ tutor E.^. TutorUser     E.==. user E.^. UserId
+      E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
+      E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+      E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
+      return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
+    mAllocation <- fmap (fmap entityVal . listToMaybe) . lift . E.select . E.from $ \(allocation `E.InnerJoin` allocationCourse) -> do
+      E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
+      E.where_ $ allocationCourse E.^. AllocationCourseCourse E.==. E.val cid
+      E.limit 1
+      return allocation
+    return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors,mAllocation)
+
+  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
+  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
+  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
+  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
+  (regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course
+  let regForm = wrapForm regWidget def
+        { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
+        , formEncoding = regEnctype
+        , formSubmit = FormNoSubmit
+        }
+  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
+
+  let
+    tutorialDBTable = DBTable{..}
+      where
+        dbtSQLQuery tutorial = do
+          E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+          return tutorial
+        dbtRowKey = (E.^. TutorialId)
+        dbtProj = return
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
+          , sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
+          , sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
+              tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
+                E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
+                E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
+                return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
+              return [whamlet|
+                       $newline never
+                       <ul .list--iconless .list--inline .list--comma-separated>
+                         $forall tutor <- tutTutors
+                           <li>
+                             ^{nameEmailWidget' tutor}
+                     |]
+          , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
+          , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime
+          , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
+          , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
+          , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
+          , sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
+              Nothing -> mempty
+              Just tutorialCapacity' -> sqlCell $ do
+                [E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
+                                                           E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
+                                                           return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
+                                                      in return $ E.val tutorialCapacity' E.-. numParticipants
+                return . toWidget . tshow $ max 0 freeCapacity
+          , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
+              mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
+              isRegistered <- case mbAid of
+                Nothing  -> return False
+                Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
+              if
+                | mayRegister -> do
+                    (tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
+                    return $ wrapForm tutRegisterForm def
+                      { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
+                      , formEncoding = tutRegisterEnctype
+                      , formSubmit = FormNoSubmit
+                      }
+                | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
+                | otherwise -> return mempty
+          ]
+        dbtSorting = Map.fromList
+          [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
+          , ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
+          , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
+          , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
+          , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
+          , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "tutorials"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+
+    tutorialDBTableValidator = def
+      & defaultSorting [SortAscBy "type", SortAscBy "name"]
+  (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
+
+  let
+    examDBTable = DBTable{..}
+      where
+        dbtSQLQuery exam = do
+          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+          return exam
+        dbtRowKey = (E.^. ExamId)
+        dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
+          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
+          return r
+        dbtColonnade = dbColonnade $ mconcat
+          [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
+          , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
+          , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+          , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
+              mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+              isRegistered <- case mbAid of
+                Nothing  -> return False
+                Just uid -> existsBy $ UniqueExamRegistration eId uid
+              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+                  examUrl = CExamR tid ssh csh examName EShowR
+              if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
+                 | otherwise   -> return [whamlet|_{label}|]
+          -- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
+          --     mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+          --     isRegistered <- case mbAid of
+          --       Nothing  -> return False
+          --       Just uid -> existsBy $ UniqueExamRegistration eId uid
+          --     if
+          --       | mayRegister -> do
+          --           (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
+          --           return $ wrapForm examRegisterForm def
+          --             { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
+          --             , formEncoding = examRegisterEnctype
+          --             , formSubmit = FormNoSubmit
+          --             }
+          --       | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
+          --       | otherwise -> return mempty
+          ]
+        dbtSorting = Map.fromList
+          [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
+          , ("time", SortColumn $ \exam -> exam E.^. ExamStart )
+          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
+          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
+          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
+          , ("registered", SortColumn $ \exam ->
+              case mbAid of
+                Nothing -> E.false
+                Just uid ->
+                  E.exists $ E.from $ \reg -> do
+                    E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
+                    E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
+            )
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+
+    examDBTableValidator = def
+      & defaultSorting [SortAscBy "time"]
+  (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
+
+  siteLayout (toWgt $ courseName course) $ do
+    setTitleI $ prependCourseTitle tid ssh csh (""::Text)
+    $(widgetFile "course")

src/Handler/Course/User.hs

@@ -0,0 +1,162 @@
+module Handler.Course.User
+  ( getCUserR, postCUserR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+import Handler.Utils
+import Database.Esqueleto.Utils.TH
+
+import Data.Function ((&))
+
+import qualified Database.Esqueleto as E
+
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+
+import Handler.Course.Register
+
+
+getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
+getCUserR = postCUserR
+postCUserR tid ssh csh uCId = do
+  -- Has authorization checks (OR):
+  --
+  --   - User is current member of course
+  --   - User has submitted in course
+  --   - User is member of registered group for course
+  --   - User is member of a tutorial for course
+  --   - User is corrector for course
+  --   - User is a tutor for course
+  --   - User is a lecturer for course
+  let currentRoute = CourseR tid ssh csh (CUserR uCId)
+  dozentId <- requireAuthId
+  uid <- decrypt uCId
+  -- DB reads
+  (cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
+    cid  <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    -- Abfrage Benutzerdaten
+    user <- get404 uid
+    registration <- getBy (UniqueParticipant uid cid)
+    -- Abfrage Teilnehmernotiz
+    let thisUniqueNote = UniqueCourseUserNote uid cid
+    mbNoteEnt <- getBy thisUniqueNote
+    (noteText,noteEdits) <- case mbNoteEnt of
+      Nothing -> return (Nothing,[])
+      (Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
+        noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
+          E.on     $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
+          E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
+          E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
+          E.limit 1 -- more will be shown, if changed here
+          return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
+        return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
+    -- Abfrage Studiengänge
+    studies <- E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
+      E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
+      E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
+      E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
+      return  (studyfeat, studydegree, studyterms)
+    return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
+  let editByWgt = [whamlet|
+          $forall (etime,_eemail,ename,_esurname) <- noteEdits
+            <br>
+            _{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
+        |] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
+
+  ((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
+      aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
+  let noteFrag :: Text
+      noteFrag = "notes"
+      noteWidget = wrapForm noteView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ currentRoute :#: noteFrag
+        , formEncoding = noteEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Just noteFrag
+        }
+  formResult noteRes $ \mbNote -> do
+    now <- liftIO getCurrentTime
+    runDB $ case mbNote of
+      Nothing -> do
+        -- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
+        maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
+        deleteBy thisUniqueNote
+        addMessageI Info MsgCourseUserNoteDeleted
+      _ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
+      (Just note) -> do
+        (Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
+        void . insert $ CourseUserNoteEdit dozentId now noteKey
+        addMessageI Success MsgCourseUserNoteSaved
+    redirect $ currentRoute :#: noteFrag -- reload page after post
+
+  ((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
+    let currentField :: Maybe (Maybe StudyFeaturesId)
+        currentField = courseParticipantField . entityVal <$> mRegistration
+     in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
+
+  let registrationFieldFrag :: Text
+      registrationFieldFrag = "registration-field"
+      regFieldWidget = wrapForm regFieldView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
+        , formEncoding = regFieldEnctype
+        , formAttrs = []
+        , formSubmit = FormAutoSubmit
+        , formAnchor = Just registrationFieldFrag
+        }
+  for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
+    formResult regFieldRes $ \courseParticipantField' -> do
+      runDB $ do
+        update pId [ CourseParticipantField =. courseParticipantField' ]
+        addMessageI Success MsgCourseStudyFeatureUpdated
+      redirect $ currentRoute :#: registrationFieldFrag
+
+  let regButton
+        | Just _ <- mRegistration = BtnCourseDeregister
+        | otherwise = BtnCourseRegister
+  ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
+
+  let registrationButtonFrag :: Text
+      registrationButtonFrag = "registration-button"
+      regButtonWidget = wrapForm regButtonView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
+        , formEncoding = regButtonEnctype
+        , formAttrs = []
+        , formSubmit = FormNoSubmit
+        , formAnchor = Just registrationButtonFrag
+        }
+  formResult regButtonRes $ \case
+    BtnCourseDeregister
+      | Just (Entity pId _) <- mRegistration
+        -> do
+          runDB $ delete pId
+          addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
+          redirect $ CourseR tid ssh csh CUsersR
+      | otherwise
+        -> invalidArgs ["User not registered"]
+    BtnCourseRegister -> do
+      now <- liftIO getCurrentTime
+      let primaryField
+            | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
+            = Just featId
+            | otherwise
+            = Nothing
+      pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField False
+      case pId of
+        Just _  -> do
+          addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
+          redirect currentRoute
+        Nothing -> invalidArgs ["User already registered"]
+
+  mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
+
+  -- generate output
+  let headingLong  = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{tid}|]
+      headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
+  siteLayout headingLong $ do
+    setTitleI headingShort
+    $(widgetFile "course-user")

src/Handler/Course/Users.hs

@@ -0,0 +1,264 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Course.Users
+  ( queryUser
+  , makeCourseUserTable
+  , postCUsersR, getCUsersR
+  , colUserDegreeShort, colUserField, colUserSemester
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+import Handler.Utils
+import Handler.Utils.Database
+import Handler.Utils.Table.Cells
+import Handler.Utils.Table.Columns
+import Database.Persist.Sql (deleteWhereCount)
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+
+import Data.Function ((&))
+
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+
+
+type UserTableExpr   = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
+        `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+        `E.LeftOuterJoin`
+        (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
+
+-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
+-- forceUserTableType = id
+
+-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
+-- This ought to ease refactoring the query
+queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+
+queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
+queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+
+queryUserNote ::  UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
+queryUserNote = $(sqlLOJproj 3 2)
+
+queryFeaturesStudy ::  UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryFeaturesStudy  = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
+
+queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
+queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
+
+queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
+queryFeaturesField  = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
+
+
+userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
+                                                          , E.SqlExpr (E.Value UTCTime)
+                                                          , E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
+                                                          , StudyFeaturesDescription')
+userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
+  -- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
+  features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
+  E.on $  (note E.?. CourseUserNoteUser   E.==. E.just (participant E.^. CourseParticipantUser))
+    E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
+  E.on $     participant E.^. CourseParticipantUser   E.==. user E.^. UserId
+  E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
+  return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
+
+
+type UserTableData   = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))
+
+instance HasEntity UserTableData User where
+  hasEntity = _dbrOutput . _1
+
+instance HasUser UserTableData where
+  -- hasUser = _entityVal
+  hasUser = _dbrOutput . _1 . _entityVal
+
+_userTableRegistration :: Lens' UserTableData UTCTime
+_userTableRegistration = _dbrOutput . _2
+
+_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
+_userTableNote = _dbrOutput . _3
+
+_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
+_userTableFeatures = _dbrOutput . _4
+
+_rowUserSemester :: Traversal' UserTableData Int
+_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
+
+
+colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
+colUserComment tid ssh csh =
+    sortable (Just "note") (i18nCell MsgCourseUserNote)
+      $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
+        maybeEmpty mbNoteKey $ const $
+          anchorCellM (courseLink <$> encrypt uid) (hasComment True)
+  where
+    courseLink = CourseR tid ssh csh . CUserR
+
+colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
+    foldMap numCell . preview _rowUserSemester
+
+colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
+    foldMap i18nCell . view (_userTableFeatures . _3)
+
+-- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+-- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
+--     foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
+
+-- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+-- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
+--     foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
+
+colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
+colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
+    foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
+
+
+data CourseUserAction = CourseUserSendMail | CourseUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe CourseUserAction
+instance Finite CourseUserAction
+nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''CourseUserAction id
+
+
+makeCourseUserTable :: forall h act.
+                       ( Functor h, ToSortable h
+                       , RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
+                    => CourseId
+                    -> (UserTableExpr -> E.SqlExpr (E.Value Bool))
+                    -> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
+                    -> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
+                    -> DB (FormResult (act, Set UserId), Widget)
+makeCourseUserTable cid restrict colChoices psValidator = do
+    Just currentRoute <- liftHandlerT getCurrentRoute
+    -- -- psValidator has default sorting and filtering
+    let dbtIdent     = "courseUsers" :: Text
+        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
+        dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
+        dbtRowKey    = queryUser >>> (E.^. UserId)
+        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
+        dbtColonnade = colChoices
+        dbtSorting   = Map.fromList
+          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+          , sortUserSurname     queryUser -- needed for initial sorting
+          , sortUserDisplayName queryUser -- needed for initial sorting
+          , sortUserEmail       queryUser
+          , sortUserMatriclenr  queryUser
+          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+                E.sub_select . E.from $ \edit -> do
+                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
+            )
+          ]
+        dbtFilter    = Map.fromList
+          [ fltrUserNameLink    queryUser
+          , fltrUserEmail       queryUser
+          , fltrUserMatriclenr  queryUser
+          , fltrUserNameEmail   queryUser
+          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , ("field"       , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
+                                 , E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
+                                 ] )
+          , ("degree"      , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
+                                 , E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
+                                 ] )
+          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+          , ("tutorial"    , FilterColumn $ E.mkExistsFilter   $ \row criterion ->
+                E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
+                  E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
+                  E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
+                       E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
+                       E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
+            )
+          -- , ("course-registration", error "TODO") -- TODO
+          -- , ("course-user-note", error "TODO") -- TODO
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailUI  mPrev
+          , fltrUserMatriclenrUI mPrev
+          , prismAForm (singletonFilter "degree")   mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
+          , prismAForm (singletonFilter "field")    mPrev $ aopt textField (fslI MsgCourseStudyFeature)
+          , prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
+          ]
+        dbtParams    = DBParamsForm
+          { dbParamsFormMethod = POST
+          , dbParamsFormAction = Just $ SomeRoute currentRoute
+          , dbParamsFormAttrs  = []
+          , dbParamsFormSubmit = FormSubmit
+          , dbParamsFormAdditional = \csrf -> do
+              (res,vw) <- mreq (selectField optionsFinite) "" Nothing
+              let formWgt = toWidget csrf <> fvInput vw
+                  formRes = (, mempty) . First . Just <$> res
+              return (formRes,formWgt)
+          , dbParamsFormEvaluate = liftHandlerT . runFormPost
+          , dbParamsFormResult   = id
+          , dbParamsFormIdent    = def
+          }
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+    over _1 postprocess <$> dbTable psValidator DBTable{..}
+  where
+    postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
+    postprocess inp = do
+      (First (Just act), usrMap) <- inp
+      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+      return (act, usrSet)
+
+getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUsersR = postCUsersR
+postCUsersR tid ssh csh = do
+  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
+    let colChoices  = mconcat
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , colUserNameLink (CourseR tid ssh csh . CUserR)
+          , colUserEmail
+          , colUserMatriclenr
+          , colUserDegreeShort
+          , colUserField
+          , colUserSemester
+          , sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
+          , colUserComment tid ssh csh
+          ]
+        psValidator = def & defaultSortingByName
+    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    numParticipants <- count [CourseParticipantCourse ==. cid]
+    table <- makeCourseUserTable cid (const E.true) colChoices psValidator
+    return (ent, numParticipants, table)
+  formResult participantRes $ \case
+    (CourseUserSendMail, selectedUsers) -> do
+        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
+        redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
+    (CourseUserDeregister,selectedUsers) -> do
+        nrDel <- runDB $ deleteWhereCount
+          [ CourseParticipantCourse ==. cid
+          , CourseParticipantUser <-. Set.toList selectedUsers
+          ]
+        addMessageI Success $ MsgCourseUsersDeregistered nrDel
+        redirect $ CourseR tid ssh csh CUsersR
+  let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
+      headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
+  siteLayout headingLong $ do
+    setTitleI headingShort
+    $(widgetFile "course-participants")

src/Handler/Exam/AddUser.hs

@@ -0,0 +1,158 @@
+module Handler.Exam.AddUser
+  ( getEAddUserR, postEAddUserR
+  ) where
+
+import Import hiding (Option(..))
+import Handler.Exam.RegistrationInvite
+
+import Handler.Utils
+import Handler.Utils.Exam
+import Handler.Utils.Invitations
+
+import Utils.Lens
+  
+import qualified Data.Set as Set
+
+import Data.Semigroup (Option(..))
+  
+import Control.Monad.Trans.Writer (WriterT, execWriterT)
+import Control.Monad.Error.Class (MonadError(..))
+
+import Jobs.Queue
+  
+import Generics.Deriving.Monoid
+
+
+data AddRecipientsResult = AddRecipientsResult
+  { aurAlreadyRegistered
+  , aurNoUniquePrimaryField
+  , aurNoCourseRegistration
+  , aurSuccess
+  , aurSuccessCourse        :: [UserEmail]
+  } deriving (Read, Show, Generic, Typeable)
+
+instance Monoid AddRecipientsResult where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+
+getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEAddUserR = postEAddUserR
+postEAddUserR tid ssh csh examn = do
+    eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
+    ((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
+      now <- liftIO getCurrentTime
+      occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
+      
+      let
+        localNow = utcToLocalTime now
+        tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
+          LTUUnique utc' _ -> utc'
+          _other           -> UTCTime (addDays 2 $ utctDay now) 0
+        earliestDate = getOption . fmap getMin $ mconcat
+          [ Option $ Min <$> examStart
+          , foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences
+          ]
+        modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate')
+          -> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of
+               LTUUnique utc' _ -> utc'
+               _other           -> UTCTime (addDays (-1) $ utctDay earliestDate') 0
+        defDeadline
+          | Just registerTo <- examRegisterTo
+          , registerTo > now
+          = registerTo
+          | Just earliestDate' <- modifiedEarliestDate
+          = max tomorrowEndOfDay earliestDate'
+          | otherwise
+          = tomorrowEndOfDay
+          
+      deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
+      enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly & setTooltip MsgExamRegistrationEnlistDirectlyTip) (Just False)
+      registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
+      occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
+      users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
+        (fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+      return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users
+
+    formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt
+
+    let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading
+
+    siteLayoutMsg heading $ do
+      setTitleI heading
+      wrapForm formWgt def
+        { formEncoding
+        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR
+        }
+  where
+    processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
+    processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
+      let (emails,uids) = partitionEithers $ Set.toList users
+      AddRecipientsResult{..} <- lift . runDBJobs $ do
+        -- send Invitation eMails to unkown users
+        sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
+        -- register known users
+        execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids
+
+      unless (null emails) $
+        tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails
+
+      unless (null aurSuccess) $
+        tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length aurSuccess
+
+      unless (null aurNoUniquePrimaryField) $ do
+        let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
+            modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
+        tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
+
+      unless (null aurNoCourseRegistration) $ do
+        let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length aurNoCourseRegistration)}|]
+            modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
+        tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
+
+      unless (null aurSuccessCourse) $
+        tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length aurSuccessCourse
+
+    registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
+    registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
+      User{..} <- lift . lift $ getJust uid
+      now <- liftIO getCurrentTime
+
+      let
+        examRegister :: YesodJobDB UniWorX ()
+        examRegister = do
+          insert_ $ ExamRegistration eid uid occId now
+          audit $ TransactionExamRegister eid uid
+
+      whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
+        throwError $ mempty { aurAlreadyRegistered = pure userEmail }
+
+      whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
+        lift $ lift examRegister
+        throwError $ mempty { aurSuccess = pure userEmail }
+
+      unless registerCourse $ 
+        throwError $ mempty { aurNoCourseRegistration = pure userEmail }
+
+      guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True)
+
+      features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
+
+      let courseParticipantField
+            | [f] <- features = Just f
+            | otherwise       = Nothing
+
+      lift . lift . insert_ $ CourseParticipant
+        { courseParticipantCourse = cid
+        , courseParticipantUser = uid
+        , courseParticipantRegistration = now
+        , courseParticipantAllocated = False
+        , ..
+        }
+      lift $ lift examRegister
+
+      return $ case courseParticipantField of
+        Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
+        Just _  -> mempty { aurSuccessCourse        = pure userEmail }
+
+

src/Handler/Exam/CorrectorInvite.hs

@@ -0,0 +1,80 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Exam.CorrectorInvite
+  ( InvitableJunction(..)
+  , InvitationDBData(..)
+  , InvitationTokenData(..)
+  , examCorrectorInvitationConfig
+  , getECInviteR, postECInviteR
+  ) where
+
+import Import
+import Handler.Utils.Invitations
+import Handler.Utils.Exam
+
+import Utils.Lens
+
+import Text.Hamlet (ihamlet)
+
+import Data.Aeson hiding (Result(..))
+
+  
+instance IsInvitableJunction ExamCorrector where
+  type InvitationFor ExamCorrector = Exam
+  data InvitableJunction ExamCorrector = JunctionExamCorrector
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData ExamCorrector = InvDBDataExamCorrector
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector))
+    (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..})
+
+instance ToJSON (InvitableJunction ExamCorrector) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction ExamCorrector) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData ExamCorrector) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+instance FromJSON (InvitationDBData ExamCorrector) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+
+instance ToJSON (InvitationTokenData ExamCorrector) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+instance FromJSON (InvitationTokenData ExamCorrector) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+
+examCorrectorInvitationConfig :: InvitationConfig ExamCorrector
+examCorrectorInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
+    invitationResolveFor _ = do
+      Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
+      fetchExamId tid csh ssh examn
+    invitationSubject (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
+    invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ _ _ = pure (JunctionExamCorrector, ())
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
+    invitationUltDest (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
+
+getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getECInviteR = postECInviteR
+postECInviteR = invitationR examCorrectorInvitationConfig

src/Handler/Exam/Edit.hs

@@ -0,0 +1,133 @@
+module Handler.Exam.Edit
+  ( getEEditR, postEEditR
+  ) where
+
+import Import
+import Handler.Exam.Form
+import Handler.Exam.CorrectorInvite
+
+import Utils.Lens
+
+import qualified Data.Set as Set
+
+import Handler.Utils
+import Handler.Utils.Exam
+import Handler.Utils.Invitations
+
+import Jobs.Queue
+
+
+getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEEditR = postEEditR
+postEEditR tid ssh csh examn = do
+  (cid, eId, template) <- runDB $ do
+    (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
+
+    template <- examFormTemplate exam
+
+    return (cid, eId, template)
+
+  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
+
+  formResult editExamResult $ \ExamForm{..} -> do
+    insertRes <- runDBJobs $ do
+      insertRes <- myReplaceUnique eId Exam
+        { examCourse           = cid
+        , examName             = efName
+        , examGradingRule      = efGradingRule
+        , examBonusRule        = efBonusRule
+        , examOccurrenceRule   = efOccurrenceRule
+        , examVisibleFrom      = efVisibleFrom
+        , examRegisterFrom     = efRegisterFrom
+        , examRegisterTo       = efRegisterTo
+        , examDeregisterUntil  = efDeregisterUntil
+        , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
+        , examStart            = efStart
+        , examEnd              = efEnd
+        , examFinished         = efFinished
+        , examClosed           = efClosed
+        , examPublicStatistics = efPublicStatistics
+        , examShowGrades       = efShowGrades
+        , examDescription      = efDescription
+        }
+
+      when (is _Nothing insertRes) $ do
+        occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
+        deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
+        forM_ (Set.toList efOccurrences) $ \case
+          ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
+            ExamOccurrence
+              { examOccurrenceExam = eId
+              , examOccurrenceName = eofName
+              , examOccurrenceRoom = eofRoom
+              , examOccurrenceCapacity = eofCapacity
+              , examOccurrenceStart = eofStart
+              , examOccurrenceEnd = eofEnd
+              , examOccurrenceDescription = eofDescription
+              }
+          ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
+            cID <- hoistMaybe eofId
+            eofId' <- decrypt cID
+            oldOcc <- MaybeT $ get eofId'
+            guard $ examOccurrenceExam oldOcc == eId
+            lift $ replace eofId' ExamOccurrence
+              { examOccurrenceExam = eId
+              , examOccurrenceName = eofName
+              , examOccurrenceRoom = eofRoom
+              , examOccurrenceCapacity = eofCapacity
+              , examOccurrenceStart = eofStart
+              , examOccurrenceEnd = eofEnd
+              , examOccurrenceDescription = eofDescription
+              }
+
+
+        pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
+        deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
+        forM_ (Set.toList efExamParts) $ \case
+          ExamPartForm{ epfId = Nothing, .. } -> insert_
+            ExamPart
+              { examPartExam = eId
+              , examPartName = epfName
+              , examPartMaxPoints = epfMaxPoints
+              , examPartWeight = epfWeight
+              }
+          ExamPartForm{ .. } -> void . runMaybeT $ do
+            cID <- hoistMaybe epfId
+            epfId' <- decrypt cID
+            oldPart <- MaybeT $ get epfId'
+            guard $ examPartExam oldPart == eId
+            lift $ replace epfId' ExamPart
+              { examPartExam = eId
+              , examPartName = epfName
+              , examPartMaxPoints = epfMaxPoints
+              , examPartWeight = epfWeight
+              }
+
+
+        let (invites, adds) = partitionEithers $ Set.toList efCorrectors
+
+        deleteWhere [ ExamCorrectorExam ==. eId ]
+        insertMany_ $ map (ExamCorrector eId) adds
+
+        deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
+        sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
+
+      return insertRes
+
+    case insertRes of
+      Just _  -> addMessageI Error $ MsgExamNameTaken efName
+      Nothing -> do
+        addMessageI Success $ MsgExamEdited efName
+        redirect $ CExamR tid ssh csh efName EShowR
+
+  let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      editExamForm = wrapForm editExamWidget def
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
+        , formEncoding = editExamEnctype
+        }
+    $(widgetFile "exam-edit")

src/Handler/Exam/Form.hs

@@ -0,0 +1,361 @@
+module Handler.Exam.Form
+  ( ExamForm(..)
+  , ExamOccurrenceForm(..)
+  , ExamPartForm(..)
+  , examForm
+  , examFormTemplate, examTemplate
+  , validateExam
+  ) where
+
+import Import
+import Utils.Lens hiding (parts)
+
+import Handler.Exam.CorrectorInvite
+
+import Handler.Utils
+import Handler.Utils.Invitations
+
+import Data.Map ((!))
+import qualified Data.Set as Set
+
+import qualified Database.Esqueleto as E
+
+import qualified Control.Monad.State.Class as State
+import Text.Blaze.Html.Renderer.String (renderHtml)
+
+
+data ExamForm = ExamForm
+  { efName :: ExamName
+  , efDescription :: Maybe Html
+  , efStart :: Maybe UTCTime
+  , efEnd :: Maybe UTCTime
+  , efVisibleFrom :: Maybe UTCTime
+  , efRegisterFrom :: Maybe UTCTime
+  , efRegisterTo :: Maybe UTCTime
+  , efDeregisterUntil :: Maybe UTCTime
+  , efPublishOccurrenceAssignments :: Maybe UTCTime
+  , efFinished :: Maybe UTCTime
+  , efClosed :: Maybe UTCTime
+  , efOccurrences :: Set ExamOccurrenceForm
+  , efShowGrades :: Bool
+  , efPublicStatistics :: Bool
+  , efGradingRule :: ExamGradingRule
+  , efBonusRule :: ExamBonusRule
+  , efOccurrenceRule :: ExamOccurrenceRule
+  , efCorrectors :: Set (Either UserEmail UserId)
+  , efExamParts :: Set ExamPartForm
+  }
+
+data ExamOccurrenceForm = ExamOccurrenceForm
+  { eofId :: Maybe CryptoUUIDExamOccurrence
+  , eofName :: ExamOccurrenceName
+  , eofRoom :: Text
+  , eofCapacity :: Natural
+  , eofStart :: UTCTime
+  , eofEnd :: Maybe UTCTime
+  , eofDescription :: Maybe Html
+  } deriving (Read, Show, Eq, Ord, Generic, Typeable)
+
+data ExamPartForm = ExamPartForm
+  { epfId :: Maybe CryptoUUIDExamPart
+  , epfName :: ExamPartName
+  , epfMaxPoints :: Maybe Points
+  , epfWeight :: Rational
+  } deriving (Read, Show, Eq, Ord, Generic, Typeable)
+
+makeLenses_ ''ExamForm
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''ExamPartForm
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''ExamOccurrenceForm
+
+
+examForm :: Maybe ExamForm -> Form ExamForm
+examForm template html = do
+  MsgRenderer mr <- getMsgRenderer
+
+  flip (renderAForm FormStandard) html $ ExamForm
+    <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
+    <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
+    <*  aformSection MsgExamFormTimes
+    <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
+    <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
+    <*  aformSection MsgExamFormOccurrences
+    <*> examOccurrenceForm (efOccurrences <$> template)
+    <*  aformSection MsgExamFormAutomaticFunctions
+    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
+    <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
+    <*> examGradingRuleForm (efGradingRule <$> template)
+    <*> examBonusRuleForm (efBonusRule <$> template)
+    <*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
+    <*  aformSection MsgExamFormCorrection
+    <*> examCorrectorsForm (efCorrectors <$> template)
+    <*  aformSection MsgExamFormParts
+    <*> examPartsForm (efExamParts <$> template)
+
+examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
+examCorrectorsForm mPrev = wFormToAForm $ do
+  MsgRenderer mr <- getMsgRenderer
+  Just currentRoute <- getCurrentRoute
+  uid <- liftHandlerT requireAuthId
+
+  let
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
+
+    miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
+    miAdd' nudge submitView csrf = do
+      (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
+      let
+        addRes'
+          | otherwise
+          = addRes <&> \newDat oldDat -> if
+              | existing <- newDat `Set.intersection` Set.fromList oldDat
+              , not $ Set.null existing
+                -> FormFailure [mr MsgExamCorrectorAlreadyAdded]
+              | otherwise
+                -> FormSuccess $ Set.toList newDat
+      return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add"))
+
+    corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User))
+    corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do
+      E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser
+      E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
+      E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
+      E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+      E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
+      return corrUser
+
+
+    miCell' :: Either UserEmail UserId -> Widget
+    miCell' (Left email) =
+      $(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
+    miCell' (Right userId) = do
+      User{..} <- liftHandlerT . runDB $ get404 userId
+      $(widgetFile "widgets/massinput/examCorrectors/cellKnown")
+
+    miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
+
+  fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)
+
+examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
+examOccurrenceForm prev = wFormToAForm $ do
+  Just currentRoute <- getCurrentRoute
+  let
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
+
+  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
+  where
+    examOccurrenceForm' nudge mPrev csrf = do
+      (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
+      (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
+      (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
+      (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
+      (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
+      (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
+      (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
+
+      return ( ExamOccurrenceForm
+                 <$> eofIdRes
+                 <*> eofNameRes
+                 <*> eofRoomRes
+                 <*> eofCapacityRes
+                 <*> eofStartRes
+                 <*> eofEndRes
+                 <*> (assertM (not . null . renderHtml) <$> eofDescRes)
+             , $(widgetFile "widgets/massinput/examRooms/form")
+             )
+
+    miAdd' nudge submitView csrf = do
+      MsgRenderer mr <- getMsgRenderer
+      (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
+      let
+        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
+          | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
+          | otherwise -> FormSuccess $ pure newDat
+      return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
+    miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
+    miIdent' :: Text
+    miIdent' = "exam-occurrences"
+
+examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
+examPartsForm prev = wFormToAForm $ do
+  Just currentRoute <- getCurrentRoute
+  let
+    miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
+    miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
+
+  fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
+  where
+    examPartForm' nudge mPrev csrf = do
+      (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
+      (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev)
+      (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
+      (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
+
+      return ( ExamPartForm
+                 <$> epfIdRes
+                 <*> epfNameRes
+                 <*> epfMaxPointsRes
+                 <*> epfWeightRes
+             , $(widgetFile "widgets/massinput/examParts/form")
+             )
+
+    miAdd' nudge submitView csrf = do
+      MsgRenderer mr <- getMsgRenderer
+      (res, formWidget) <- examPartForm' nudge Nothing csrf
+      let
+        addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
+          | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists]
+          | otherwise -> FormSuccess $ pure newDat
+      return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
+    miCell' nudge dat = examPartForm' nudge (Just dat)
+    miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
+    miIdent' :: Text
+    miIdent' = "exam-parts"
+
+examFormTemplate :: Entity Exam -> DB ExamForm
+examFormTemplate (Entity eId Exam{..}) = do
+  parts <- selectList [ ExamPartExam ==. eId ] []
+  occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
+  correctors <- selectList [ ExamCorrectorExam ==. eId ] []
+  invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
+
+  parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
+  occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
+
+  return ExamForm
+    { efName             = examName
+    , efGradingRule      = examGradingRule
+    , efBonusRule        = examBonusRule
+    , efOccurrenceRule   = examOccurrenceRule
+    , efVisibleFrom      = examVisibleFrom
+    , efRegisterFrom     = examRegisterFrom
+    , efRegisterTo       = examRegisterTo
+    , efDeregisterUntil  = examDeregisterUntil
+    , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
+    , efStart            = examStart
+    , efEnd              = examEnd
+    , efFinished         = examFinished
+    , efClosed           = examClosed
+    , efShowGrades       = examShowGrades
+    , efPublicStatistics = examPublicStatistics
+    , efDescription      = examDescription
+    , efOccurrences      = Set.fromList $ do
+        (Just -> eofId, ExamOccurrence{..}) <- occurrences'
+        return ExamOccurrenceForm
+          { eofId
+          , eofName        = examOccurrenceName
+          , eofRoom        = examOccurrenceRoom
+          , eofCapacity    = examOccurrenceCapacity
+          , eofStart       = examOccurrenceStart
+          , eofEnd         = examOccurrenceEnd
+          , eofDescription = examOccurrenceDescription
+          }
+    , efExamParts        = Set.fromList $ do
+        (Just -> epfId, ExamPart{..}) <- parts'
+        return ExamPartForm
+          { epfId
+          , epfName      = examPartName
+          , epfMaxPoints = examPartMaxPoints
+          , epfWeight    = examPartWeight
+          }
+    , efCorrectors       = Set.unions
+      [ Set.fromList $ map Left invitations
+      , Set.fromList . map Right $ do
+          Entity _ ExamCorrector{..} <- correctors
+          return examCorrectorUser
+      ]
+    }
+
+examTemplate :: CourseId -> DB (Maybe ExamForm)
+examTemplate cid = runMaybeT $ do
+  newCourse <- MaybeT $ get cid
+
+  [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
+    E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
+    E.where_ $ (       course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
+                 E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
+               )
+         E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
+    E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
+      E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
+      E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
+    E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
+    E.limit 1
+    E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
+    return (course, exam)
+
+  oldTerm <- MaybeT . get $ courseTerm oldCourse
+  newTerm <- MaybeT . get $ courseTerm newCourse
+
+  let
+    dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm
+
+  return ExamForm
+    { efName             = examName oldExam
+    , efGradingRule      = examGradingRule oldExam
+    , efBonusRule        = examBonusRule oldExam
+    , efOccurrenceRule   = examOccurrenceRule oldExam
+    , efVisibleFrom      = dateOffset <$> examVisibleFrom oldExam
+    , efRegisterFrom     = dateOffset <$> examRegisterFrom oldExam
+    , efRegisterTo       = dateOffset <$> examRegisterTo oldExam
+    , efDeregisterUntil  = dateOffset <$> examDeregisterUntil oldExam
+    , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
+    , efStart            = dateOffset <$> examStart oldExam
+    , efEnd              = dateOffset <$> examEnd oldExam
+    , efFinished         = dateOffset <$> examFinished oldExam
+    , efClosed           = dateOffset <$> examClosed oldExam
+    , efShowGrades       = examShowGrades oldExam
+    , efPublicStatistics = examPublicStatistics oldExam
+    , efDescription      = examDescription oldExam
+    , efOccurrences      = Set.empty
+    , efExamParts        = Set.empty
+    , efCorrectors       = Set.empty
+    }
+
+
+validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
+validateExam = do
+  ExamForm{..} <- State.get
+
+  guardValidation MsgExamRegisterToMustBeAfterRegisterFrom                 $ NTop efRegisterTo                   >= NTop efRegisterFrom
+  guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom            $ NTop efDeregisterUntil              >= NTop efRegisterFrom
+  guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments      . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
+  guardValidation MsgExamEndMustBeAfterStart                               $ NTop efEnd                          >= NTop efStart
+  guardValidation MsgExamFinishedMustBeAfterEnd                            . fromMaybe True $ (>=) <$> efFinished <*> efEnd
+  guardValidation MsgExamFinishedMustBeAfterStart                          $ NTop efFinished                     >= NTop efStart
+  guardValidation MsgExamClosedMustBeAfterFinished                         . fromMaybe True $ (>=) <$> efClosed <*> efFinished
+  guardValidation MsgExamClosedMustBeAfterStart                            $ NTop efClosed                       >= NTop efStart
+  guardValidation MsgExamClosedMustBeAfterEnd                              . fromMaybe True $ (>=) <$> efClosed <*> efEnd
+
+  forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
+    guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
+    guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
+    warn_Validation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName)    $ NTop eofEnd <= NTop efEnd
+
+  forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
+    eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
+
+    guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
+      [ (/=) `on` eofRoom
+      , (/=) `on` eofStart
+      , (/=) `on` eofEnd
+      , (/=) `on` fmap renderHtml . eofDescription
+      ]
+
+    guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b

src/Handler/Exam/List.hs

@@ -0,0 +1,60 @@
+module Handler.Exam.List
+  ( getCExamListR
+  ) where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Table.Cells
+  
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+
+
+getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCExamListR tid ssh csh = do
+  Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
+  now <- liftIO getCurrentTime
+  mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
+
+  let
+    examDBTable = DBTable{..}
+      where
+        dbtSQLQuery exam = do
+          E.where_ $ exam E.^. ExamCourse E.==. E.val cid
+          return exam
+        dbtRowKey = (E.^. ExamId)
+        dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
+          guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
+          return x
+        dbtColonnade = dbColonnade . mconcat $ catMaybes
+          [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
+          , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
+          , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
+          , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
+          , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+          ]
+        dbtSorting = Map.fromList
+          [ ("name", SortColumn $ \exam -> exam E.^. ExamName )
+          , ("time", SortColumn $ \exam -> exam E.^. ExamStart )
+          , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
+          , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
+          , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
+          ]
+        dbtFilter = Map.empty
+        dbtFilterUI = const mempty
+        dbtStyle = def
+        dbtParams = def
+        dbtIdent :: Text
+        dbtIdent = "exams"
+        dbtCsvEncode = noCsvEncode
+        dbtCsvDecode = Nothing
+
+    examDBTableValidator = def
+      & defaultSorting [SortAscBy "time"]
+  ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
+
+  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
+    setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
+    $(widgetFile "exam-list")

src/Handler/Exam/New.hs

@@ -0,0 +1,93 @@
+module Handler.Exam.New
+  ( getCExamNewR, postCExamNewR
+  ) where
+
+import Import
+import Handler.Exam.Form
+import Handler.Exam.CorrectorInvite
+
+import qualified Data.Set as Set
+
+import Handler.Utils
+import Handler.Utils.Invitations
+
+import Jobs.Queue
+
+
+getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCExamNewR = postCExamNewR
+postCExamNewR tid ssh csh = do
+  (cid, template) <- runDB $ do
+    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    template <- examTemplate cid
+    return (cid, template)
+
+  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
+
+  formResult newExamResult $ \ExamForm{..} -> do
+    insertRes <- runDBJobs $ do
+      insertRes <- insertUnique Exam
+        { examName                         = efName
+        , examCourse                       = cid
+        , examGradingRule                  = efGradingRule
+        , examBonusRule                    = efBonusRule
+        , examOccurrenceRule               = efOccurrenceRule
+        , examVisibleFrom                  = efVisibleFrom
+        , examRegisterFrom                 = efRegisterFrom
+        , examRegisterTo                   = efRegisterTo
+        , examDeregisterUntil              = efDeregisterUntil
+        , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
+        , examStart                        = efStart
+        , examEnd                          = efEnd
+        , examFinished                     = efFinished
+        , examClosed                       = efClosed
+        , examShowGrades                   = efShowGrades
+        , examPublicStatistics             = efPublicStatistics
+        , examDescription                  = efDescription
+        }
+      whenIsJust insertRes $ \examid -> do
+        insertMany_
+          [ ExamPart{..}
+          | ExamPartForm{..} <- Set.toList efExamParts
+          , let examPartExam      = examid
+                examPartName      = epfName
+                examPartMaxPoints = epfMaxPoints
+                examPartWeight    = epfWeight
+          ]
+
+        insertMany_
+          [ ExamOccurrence{..}
+          | ExamOccurrenceForm{..} <- Set.toList efOccurrences
+          , let examOccurrenceExam        = examid
+                examOccurrenceName        = eofName
+                examOccurrenceRoom        = eofRoom
+                examOccurrenceCapacity    = eofCapacity
+                examOccurrenceStart       = eofStart
+                examOccurrenceEnd         = eofEnd
+                examOccurrenceDescription = eofDescription
+          ]
+
+        let (invites, adds) = partitionEithers $ Set.toList efCorrectors
+        insertMany_ [ ExamCorrector{..}
+                    | examCorrectorUser <- adds
+                    , let examCorrectorExam = examid
+                    ]
+        sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
+      return insertRes
+    case insertRes of
+      Nothing -> addMessageI Error $ MsgExamNameTaken efName
+      Just _  -> do
+        addMessageI Success $ MsgExamCreated efName
+        redirect $ CourseR tid ssh csh CExamListR
+
+  let heading = prependCourseTitle tid ssh csh MsgExamNew
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      newExamForm = wrapForm newExamWidget def
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR
+        , formEncoding = newExamEnctype
+        }
+    $(widgetFile "exam-new")

src/Handler/Exam/Register.hs

@@ -0,0 +1,52 @@
+module Handler.Exam.Register
+  ( ButtonExamRegister(..)
+  , postERegisterR
+  ) where
+
+import Import
+
+import Handler.Utils
+import Handler.Utils.Exam
+
+
+-- Dedicated ExamRegistrationButton
+data ButtonExamRegister = BtnExamRegister | BtnExamDeregister
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonExamRegister
+instance Finite ButtonExamRegister
+nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonExamRegister id
+instance Button UniWorX ButtonExamRegister where
+  btnClasses BtnExamRegister   = [BCIsButton, BCPrimary]
+  btnClasses BtnExamDeregister = [BCIsButton, BCDanger]
+
+  btnLabel  BtnExamRegister   = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|]
+  btnLabel  BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|]
+
+
+postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+
+postERegisterR tid ssh csh examn = do
+  Entity uid User{..} <- requireAuth
+
+  Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
+
+  ((btnResult, _), _) <- runFormPost buttonForm
+
+  formResult btnResult $ \case
+    BtnExamRegister -> do
+      runDB $ do
+        now <- liftIO getCurrentTime
+        insert_ $ ExamRegistration eId uid Nothing now
+        audit $ TransactionExamRegister eId uid
+      addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn
+      redirect $ CExamR tid ssh csh examn EShowR
+    BtnExamDeregister -> do
+      runDB $ do
+        deleteBy $ UniqueExamRegistration eId uid
+        audit $ TransactionExamDeregister eId uid
+      addMessageIconI Info IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn
+        -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
+      redirect $ CExamR tid ssh csh examn EShowR
+
+  invalidArgs ["Register/Deregister button required"]

src/Handler/Exam/RegistrationInvite.hs

@@ -0,0 +1,110 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Exam.RegistrationInvite
+  ( InvitableJunction(..)
+  , InvitationDBData(..)
+  , InvitationTokenData(..)
+  , examRegistrationInvitationConfig
+  , getEInviteR, postEInviteR
+  ) where
+
+import Import
+import Handler.Utils
+import Handler.Utils.Exam
+import Handler.Utils.Invitations
+
+import qualified Data.Set as Set
+
+import Text.Hamlet (ihamlet)
+
+import Utils.Lens
+  
+import Data.Aeson hiding (Result(..))
+  
+
+instance IsInvitableJunction ExamRegistration where
+  type InvitationFor ExamRegistration = Exam
+  data InvitableJunction ExamRegistration = JunctionExamRegistration
+    { jExamRegistrationOccurrence :: Maybe ExamOccurrenceId
+    , jExamRegistrationTime :: UTCTime
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData ExamRegistration = InvDBDataExamRegistration
+    { invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId
+    , invDBExamRegistrationDeadline :: UTCTime
+    , invDBExamRegistrationCourseRegister :: Bool
+    } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime))
+    (\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..})
+
+instance ToJSON (InvitableJunction ExamRegistration) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction ExamRegistration) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData ExamRegistration) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+instance FromJSON (InvitationDBData ExamRegistration) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
+
+instance ToJSON (InvitationTokenData ExamRegistration) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+instance FromJSON (InvitationTokenData ExamRegistration) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
+
+examRegistrationInvitationConfig :: InvitationConfig ExamRegistration
+examRegistrationInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
+    invitationResolveFor _ = do
+      Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
+      fetchExamId tid csh ssh examn
+    invitationSubject (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
+    invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
+    invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
+      itAuthority <- liftHandlerT requireAuthId
+      let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
+          itAddAuth
+            | not invDBExamRegistrationCourseRegister
+            = Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered
+            | otherwise
+            = Nothing
+          itStartsAt = Nothing
+      return InvitationTokenConfig{..}
+    invitationRestriction _ _ = return Authorized
+    invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
+      isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
+      now <- liftIO getCurrentTime
+
+      case (isRegistered, invDBExamRegistrationCourseRegister) of
+        (False, False) -> permissionDeniedI MsgUnauthorizedParticipant
+        (False, True ) -> do
+          fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
+          return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
+        (True , _    ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) 
+    invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
+      whenIsJust mField $ \cpField -> 
+        insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
+      
+      let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
+      act <* doAudit
+    invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
+    invitationUltDest (Entity _ Exam{..}) _ = do
+      Course{..} <- get404 examCourse
+      return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
+
+
+getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEInviteR = postEInviteR
+postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig

src/Handler/Exam/Show.hs

@@ -0,0 +1,106 @@
+module Handler.Exam.Show
+  ( getEShowR
+  ) where
+
+import Import
+import Handler.Exam.Register
+
+import Utils.Lens hiding (parts)
+
+import Data.Map ((!?))
+import qualified Data.Map as Map
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+import qualified Data.CaseInsensitive as CI
+
+import Handler.Utils
+import Handler.Utils.Exam
+
+
+getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEShowR tid ssh csh examn = do
+  cTime <- liftIO getCurrentTime
+  mUid <- maybeAuthId
+
+  (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
+    exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
+
+    let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
+
+    let gradingVisible = NTop (Just cTime) >= NTop examFinished
+    gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
+    occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
+
+    resultsRaw <- for mUid $ \uid ->
+      E.select . E.from $ \examPartResult -> do
+        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
+             E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
+        return examPartResult
+    let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
+
+    result <- fmap join . for mUid $ getBy . UniqueExamResult eId
+
+    occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
+      E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
+      let
+        registered
+          | Just uid <- mUid
+          = E.exists . E.from $ \examRegistration ->
+              E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
+                   E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+                   E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
+          | otherwise = E.false
+      E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
+      return (examOccurrence, registered)
+
+    let occurrences = map (over _2 E.unValue) occurrencesRaw
+
+    registered <- for mUid $ existsBy . UniqueExamRegistration eId
+    mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
+
+    occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
+
+    return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
+
+  let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
+      registerWidget
+        | Just isRegistered <- registered
+        , mayRegister = Just $ do
+            (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
+            [whamlet|
+              <p>
+                $if isRegistered
+                  _{MsgExamRegistered}
+                $else
+                  _{MsgExamNotRegistered}
+            |]
+            wrapForm examRegisterForm def
+              { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
+              , formEncoding = examRegisterEnctype
+              , formSubmit = FormNoSubmit
+            }
+        | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
+        | otherwise = Nothing
+
+  let heading = prependCourseTitle tid ssh csh $ CI.original examName
+
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    let
+      gradingKeyW :: [Points] -> Widget
+      gradingKeyW bounds
+        = let boundWidgets :: [Widget]
+              boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds
+              grades :: [ExamGrade]
+              grades = universeF
+           in $(widgetFile "widgets/gradingKey")
+
+      examBonusW :: ExamBonusRule -> Widget
+      examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
+    $(widgetFile "exam-show")

src/Handler/Exam/Users.hs

@@ -0,0 +1,675 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Exam.Users
+  ( getEUsersR, postEUsersR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils
+import Handler.Utils.Exam
+import Handler.Utils.Table.Columns
+import Handler.Utils.Table.Cells
+import Handler.Utils.Csv
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+import Database.Esqueleto.Utils.TH
+  
+import qualified Data.Csv as Csv
+  
+import Data.Map ((!))
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+  
+import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
+  
+import qualified Data.Conduit.List as C
+  
+import qualified Data.CaseInsensitive as CI
+
+import Numeric.Lens (integral)
+import Control.Arrow (Kleisli(..))
+
+import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
+
+
+type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
+type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult), Maybe (Entity CourseUserNote))
+
+instance HasEntity ExamUserTableData User where
+  hasEntity = _dbrOutput . _2
+
+instance HasUser ExamUserTableData where
+  hasUser = _dbrOutput . _2 . _entityVal
+
+_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
+_userTableOccurrence = _dbrOutput . _3
+
+queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 5 1)
+
+queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
+queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+
+queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 5 1)
+
+queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
+queryExamOccurrence = $(sqlLOJproj 5 2)
+
+queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
+queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+
+queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
+queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 5 3)
+
+queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
+queryExamResult = $(sqlLOJproj 5 4)
+
+queryCourseNote :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
+queryCourseNote = $(sqlLOJproj 5 5)
+
+resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
+resultExamRegistration = _dbrOutput . _1
+
+resultUser :: Lens' ExamUserTableData (Entity User)
+resultUser = _dbrOutput . _2
+
+resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
+resultStudyFeatures = _dbrOutput . _4 . _Just
+
+resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
+resultStudyDegree = _dbrOutput . _5 . _Just
+
+resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
+resultStudyField = _dbrOutput . _6 . _Just
+
+resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
+resultExamOccurrence = _dbrOutput . _3 . _Just
+
+resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
+resultExamResult = _dbrOutput . _7 . _Just
+
+resultCourseNote :: Traversal' ExamUserTableData (Entity CourseUserNote)
+resultCourseNote = _dbrOutput . _8 . _Just
+
+data ExamUserTableCsv = ExamUserTableCsv
+  { csvEUserSurname :: Maybe Text
+  , csvEUserFirstName :: Maybe Text
+  , csvEUserName :: Maybe Text
+  , csvEUserMatriculation :: Maybe Text
+  , csvEUserField :: Maybe Text
+  , csvEUserDegree :: Maybe Text
+  , csvEUserSemester :: Maybe Int
+  , csvEUserOccurrence :: Maybe (CI Text)
+  , csvEUserExercisePoints :: Maybe Points
+  , csvEUserExerciseNumPasses :: Maybe Int
+  , csvEUserExercisePointsMax :: Maybe Points
+  , csvEUserExerciseNumPassesMax :: Maybe Int
+  , csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
+  , csvEUserCourseNote :: Maybe Html
+  }
+  deriving (Generic)
+makeLenses_ ''ExamUserTableCsv
+
+examUserTableCsvOptions :: Csv.Options
+examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
+
+instance ToNamedRecord ExamUserTableCsv where
+  toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
+
+instance FromNamedRecord ExamUserTableCsv where
+  parseNamedRecord csv -- Manually defined awaiting issue #427
+    = ExamUserTableCsv
+      <$> csv .:? "surname"
+      <*> csv .:? "first-name"
+      <*> csv .:? "name"
+      <*> csv .:? "matriculation"
+      <*> csv .:? "field"
+      <*> csv .:? "degree"
+      <*> csv .:? "semester"
+      <*> csv .:? "occurrence"
+      <*> csv .:? "exercise-points"
+      <*> csv .:? "exercise-num-passes"
+      <*> csv .:? "exercise-points-max"
+      <*> csv .:? "exercise-num-passes-max"
+      <*> csv .:? "exam-result"
+      <*> csv .:? "course-note"
+    where
+      (.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
+      m .:? name = Csv.lookup m name <|> return Nothing
+
+instance DefaultOrdered ExamUserTableCsv where
+  headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
+
+instance CsvColumnsExplained ExamUserTableCsv where
+  csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
+    [ ('csvEUserSurname             , MsgCsvColumnExamUserSurname           )
+    , ('csvEUserFirstName           , MsgCsvColumnExamUserFirstName         )
+    , ('csvEUserName                , MsgCsvColumnExamUserName              )
+    , ('csvEUserMatriculation       , MsgCsvColumnExamUserMatriculation     )
+    , ('csvEUserField               , MsgCsvColumnExamUserField             )
+    , ('csvEUserDegree              , MsgCsvColumnExamUserDegree            )
+    , ('csvEUserSemester            , MsgCsvColumnExamUserSemester          )
+    , ('csvEUserOccurrence          , MsgCsvColumnExamUserOccurrence        )
+    , ('csvEUserExercisePoints      , MsgCsvColumnExamUserExercisePoints    )
+    , ('csvEUserExerciseNumPasses   , MsgCsvColumnExamUserExercisePasses    )
+    , ('csvEUserExercisePointsMax   , MsgCsvColumnExamUserExercisePointsMax )
+    , ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
+    , ('csvEUserExamResult          , MsgCsvColumnExamUserResult            )
+    , ('csvEUserCourseNote          , MsgCsvColumnExamUserCourseNote        )
+    ]
+
+data ExamUserAction = ExamUserDeregister
+                    | ExamUserAssignOccurrence
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe ExamUserAction
+instance Finite ExamUserAction
+nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''ExamUserAction id
+
+data ExamUserActionData = ExamUserDeregisterData
+                        | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
+
+data ExamUserCsvActionClass
+  = ExamUserCsvCourseRegister
+  | ExamUserCsvRegister
+  | ExamUserCsvAssignOccurrence
+  | ExamUserCsvSetCourseField
+  | ExamUserCsvSetResult
+  | ExamUserCsvSetCourseNote
+  | ExamUserCsvDeregister
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
+
+data ExamUserCsvAction
+  = ExamUserCsvCourseRegisterData
+    { examUserCsvActUser :: UserId
+    , examUserCsvActCourseField :: Maybe StudyFeaturesId
+    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+    }
+  | ExamUserCsvRegisterData
+    { examUserCsvActUser :: UserId
+    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+    }
+  | ExamUserCsvAssignOccurrenceData
+    { examUserCsvActRegistration :: ExamRegistrationId
+    , examUserCsvActOccurrence :: Maybe ExamOccurrenceId
+    }
+  | ExamUserCsvSetCourseFieldData
+    { examUserCsvActCourseParticipant :: CourseParticipantId
+    , examUserCsvActCourseField :: Maybe StudyFeaturesId
+    }
+  | ExamUserCsvDeregisterData
+    { examUserCsvActRegistration :: ExamRegistrationId
+    }
+  | ExamUserCsvSetResultData
+    { examUserCsvActUser :: UserId
+    , examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
+    }
+  | ExamUserCsvSetCourseNoteData
+    { examUserCsvActUser :: UserId
+    , examUserCsvActCourseNote :: Maybe Html
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
+  , fieldLabelModifier = camelToPathPiece' 3
+  , sumEncoding = TaggedObject "action" "data"
+  } ''ExamUserCsvAction
+
+data ExamUserCsvException
+  = ExamUserCsvExceptionNoMatchingUser
+  | ExamUserCsvExceptionNoMatchingStudyFeatures
+  | ExamUserCsvExceptionNoMatchingOccurrence
+  deriving (Show, Generic, Typeable)
+
+instance Exception ExamUserCsvException
+
+embedRenderMessage ''UniWorX ''ExamUserCsvException id
+
+getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
+getEUsersR = postEUsersR
+postEUsersR tid ssh csh examn = do
+  (registrationResult, examUsersTable) <- runDB $ do
+    exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
+    bonus <- examBonus exam
+
+    let
+      allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
+      showPasses     = numSheetsPasses allBoni /= 0
+      showPoints     = getSum (numSheetsPoints allBoni) /= 0
+
+      resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade
+      resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades
+
+    let
+      examUsersDBTable = DBTable{..}
+        where
+          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult `E.LeftOuterJoin` courseUserNote) = do
+            E.on $ courseUserNote E.?. CourseUserNoteUser E.==. E.just (user E.^. UserId)
+             E.&&. courseUserNote E.?. CourseUserNoteCourse E.==. E.just (E.val examCourse)
+            E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
+             E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
+            E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
+            E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
+            E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
+            E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
+             E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
+            E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
+             E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
+            E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
+            E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
+            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult, courseUserNote)
+          dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
+          dbtProj = return
+          dbtColonnade = mconcat $ catMaybes
+            [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
+            , pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
+            , pure   colUserMatriclenr
+            , pure $ colField            resultStudyField
+            , pure $ colDegreeShort      resultStudyDegree
+            , pure $ colFeaturesSemester resultStudyFeatures
+            , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
+            , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+                SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
+                SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
+                return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
+            , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
+                SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
+                SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
+                return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
+            , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
+            , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
+            , pure . sortable (Just "note") (i18nCell MsgCourseUserNote) $ \((,) <$> view (resultUser . _entityKey) <*> has resultCourseNote -> (uid, hasNote))
+                -> bool mempty (anchorCellM (CourseR tid ssh csh . CUserR <$> encrypt uid) $ hasComment True) hasNote
+            ]
+          dbtSorting = Map.fromList
+            [ sortUserNameLink     queryUser
+            , sortUserMatriclenr   queryUser
+            , sortField            queryStudyField
+            , sortDegreeShort      queryStudyDegree
+            , sortFeaturesSemester queryStudyFeatures
+            , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
+            , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
+            , ("note", SortColumn $ queryCourseNote >>> \note -> -- sort by last edit date
+                E.sub_select . E.from $ \edit -> do
+                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
+              )
+            ]
+          dbtFilter = Map.fromList
+            [ fltrUserNameEmail    queryUser
+            , fltrUserMatriclenr   queryUser
+            , fltrField            queryStudyField
+            , fltrDegree           queryStudyDegree
+            , fltrFeaturesSemester queryStudyFeatures
+            , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
+            , ( "result-bool"
+              , FilterColumn $ \row criteria -> if
+                  | Set.null criteria -> E.true
+                  | otherwise -> let passed :: [ExamResultGrade]
+                                     passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
+                                     criteria' = Set.map (fmap $ review passingGrade) criteria
+                                     criteria''
+                                       | ExamAttended (ExamPassed True) `Set.member` criteria
+                                       = criteria' `Set.union` Set.fromList passed
+                                       | otherwise  
+                                       = criteria'
+                                  in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
+              )
+            ]
+          dbtFilterUI mPrev = mconcat $ catMaybes
+            [ Just $ fltrUserNameEmailUI    mPrev
+            , Just $ fltrUserMatriclenrUI   mPrev
+            , Just $ fltrFieldUI            mPrev
+            , Just $ fltrDegreeUI           mPrev
+            , Just $ fltrFeaturesSemesterUI mPrev
+            , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
+            , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
+            , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
+            ]
+          dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
+          dbtParams = DBParamsForm
+            { dbParamsFormMethod = POST
+            , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
+            , dbParamsFormAttrs  = []
+            , dbParamsFormSubmit = FormSubmit
+            , dbParamsFormAdditional = \csrf -> do
+                let
+                  actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
+                  actionMap = Map.fromList
+                    [ ( ExamUserDeregister
+                      , pure ExamUserDeregisterData
+                      )
+                    , ( ExamUserAssignOccurrence
+                      , ExamUserAssignOccurrenceData
+                        <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
+                      )
+                    ]
+                (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
+                let formRes = (, mempty) . First . Just <$> res
+                return (formRes, formWgt)
+            , dbParamsFormEvaluate = liftHandlerT . runFormPost
+            , dbParamsFormResult   = id
+            , dbParamsFormIdent    = def
+            }
+          dbtIdent :: Text
+          dbtIdent = "exam-users"
+          dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
+          dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
+            <$> view (resultUser . _entityVal . _userSurname . to Just)
+            <*> view (resultUser . _entityVal . _userFirstName . to Just)
+            <*> view (resultUser . _entityVal . _userDisplayName . to Just)
+            <*> view (resultUser . _entityVal . _userMatrikelnummer)
+            <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
+            <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
+            <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
+            <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
+            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
+            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
+            <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
+            <*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
+            <*> preview (resultCourseNote . _entityVal . _courseUserNoteNote)
+          dbtCsvDecode = Just DBTCsvDecode
+            { dbtCsvRowKey = \csv -> do
+                uid <- lift $ view _2 <$> guessUser csv
+                fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
+            , dbtCsvComputeActions = \case
+                DBCsvDiffMissing{dbCsvOldKey}
+                  -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
+                DBCsvDiffNew{dbCsvNewKey = Just _}
+                  -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
+                DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
+                  (isPart, uid) <- lift $ guessUser dbCsvNew
+                  if
+                    | isPart -> do
+                        yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
+                        newFeatures <- lift $ lookupStudyFeatures dbCsvNew
+                        Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
+                        when (newFeatures /= oldFeatures) $
+                          yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
+                    | otherwise ->
+                        yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
+                  when (is _Just $ csvEUserExamResult dbCsvNew) $
+                    yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
+
+                  note <- lift . getBy $ UniqueCourseUserNote uid examCourse
+                  when (csvEUserCourseNote dbCsvNew /= note ^? _Just . _entityVal . _courseUserNoteNote) $
+                    yield . ExamUserCsvSetCourseNoteData uid $ csvEUserCourseNote dbCsvNew
+                DBCsvDiffExisting{..} -> do
+                  newOccurrence <- lift $ lookupOccurrence dbCsvNew
+                  when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
+                    yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
+
+                  newFeatures <- lift $ lookupStudyFeatures dbCsvNew
+                  when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
+                    Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
+                    yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
+
+                  when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
+                    yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
+
+                  when (csvEUserCourseNote dbCsvNew /= dbCsvOld ^? resultCourseNote . _entityVal . _courseUserNoteNote) $
+                    yield . ExamUserCsvSetCourseNoteData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserCourseNote dbCsvNew
+            , dbtCsvClassifyAction = \case
+                ExamUserCsvCourseRegisterData{}   -> ExamUserCsvCourseRegister
+                ExamUserCsvRegisterData{}         -> ExamUserCsvRegister
+                ExamUserCsvDeregisterData{}       -> ExamUserCsvDeregister
+                ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
+                ExamUserCsvSetCourseFieldData{}   -> ExamUserCsvSetCourseField
+                ExamUserCsvSetResultData{}        -> ExamUserCsvSetResult
+                ExamUserCsvSetCourseNoteData{}    -> ExamUserCsvSetCourseNote
+            , dbtCsvCoarsenActionClass = \case
+                ExamUserCsvCourseRegister -> DBCsvActionNew
+                ExamUserCsvRegister       -> DBCsvActionNew
+                ExamUserCsvDeregister     -> DBCsvActionMissing
+                _other                    -> DBCsvActionExisting 
+            , dbtCsvExecuteActions = do
+                C.mapM_ $ \case
+                  ExamUserCsvCourseRegisterData{..} -> do
+                    now <- liftIO getCurrentTime
+                    insert_ CourseParticipant
+                      { courseParticipantCourse = examCourse
+                      , courseParticipantUser = examUserCsvActUser
+                      , courseParticipantRegistration = now
+                      , courseParticipantField = examUserCsvActCourseField
+                      , courseParticipantAllocated = False
+                      }
+                    insert_ ExamRegistration
+                      { examRegistrationExam = eid
+                      , examRegistrationUser = examUserCsvActUser
+                      , examRegistrationOccurrence = examUserCsvActOccurrence
+                      , examRegistrationTime = now
+                      }
+                    audit $ TransactionExamRegister eid examUserCsvActUser
+                  ExamUserCsvRegisterData{..} -> do
+                    examRegistrationTime <- liftIO getCurrentTime
+                    insert_ ExamRegistration
+                      { examRegistrationExam = eid
+                      , examRegistrationUser = examUserCsvActUser
+                      , examRegistrationOccurrence = examUserCsvActOccurrence
+                      , ..
+                      }
+                    audit $ TransactionExamRegister eid examUserCsvActUser
+                  ExamUserCsvAssignOccurrenceData{..} ->
+                    update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
+                  ExamUserCsvSetCourseFieldData{..} ->
+                    update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
+                  ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
+                    Nothing  -> do
+                      deleteBy $ UniqueExamResult eid examUserCsvActUser
+                      audit $ TransactionExamResultDeleted eid examUserCsvActUser
+                    Just res -> do
+                      let res' = either (over _examResult $ review passingGrade) id res
+                      now <- liftIO getCurrentTime
+                      void $ upsertBy
+                        (UniqueExamResult eid examUserCsvActUser)
+                        (ExamResult eid examUserCsvActUser res' now)
+                        [ ExamResultResult =. res'
+                        , ExamResultLastChanged =. now
+                        ]
+                      audit $ TransactionExamResultEdit eid examUserCsvActUser
+                  ExamUserCsvDeregisterData{..} -> do
+                    ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
+                    audit $ TransactionExamDeregister eid examRegistrationUser
+                    delete examUserCsvActRegistration
+                  ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Nothing, .. } -> do
+                    noteId <- getKeyBy $ UniqueCourseUserNote examUserCsvActUser examCourse
+                    whenIsJust noteId $ \nid -> do
+                      deleteWhere [CourseUserNoteEditNote ==. nid]
+                      delete nid
+                  ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
+                    now <- liftIO getCurrentTime
+                    uid <- liftHandlerT requireAuthId
+                    Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] 
+                    insert_ $ CourseUserNoteEdit uid now nid
+                return $ CExamR tid ssh csh examn EUsersR
+            , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
+                ExamUserCsvCourseRegisterData{..} -> do
+                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe features <- examUserCsvActCourseField
+                      , ^{studyFeaturesWidget features}
+                    $nothing
+                      , _{MsgCourseStudyFeatureNone}
+                    $maybe ExamOccurrence{examOccurrenceName} <- occ
+                      \ (#{examOccurrenceName})
+                    $nothing
+                      \ (_{MsgExamNoOccurrence})
+                  |]
+                ExamUserCsvRegisterData{..} -> do
+                  (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe ExamOccurrence{examOccurrenceName} <- occ
+                      \ (#{examOccurrenceName})
+                    $nothing
+                      \ (_{MsgExamNoOccurrence})
+                  |]
+                ExamUserCsvAssignOccurrenceData{..} -> do
+                  occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
+                  [whamlet|
+                    $newline never
+                    ^{registeredUserName' examUserCsvActRegistration}
+                    $maybe ExamOccurrence{examOccurrenceName} <- occ
+                      \ (#{examOccurrenceName})
+                    $nothing
+                      \ (_{MsgExamNoOccurrence})
+                  |]
+                ExamUserCsvSetCourseFieldData{..} -> do
+                  User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe features <- examUserCsvActCourseField
+                      , ^{studyFeaturesWidget features}
+                    $nothing
+                      , _{MsgCourseStudyFeatureNone}
+                  |]
+                ExamUserCsvSetResultData{..} -> do
+                  User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $maybe newResult <- examUserCsvActExamResult
+                      $case newResult
+                        $of Left pResult
+                          , _{pResult}
+                        $of Right gResult
+                          , _{gResult}
+                    $nothing
+                      , _{MsgExamResultNone}
+                  |]
+                ExamUserCsvSetCourseNoteData{..} -> do
+                  User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
+                  [whamlet|
+                    $newline never
+                    ^{nameWidget userDisplayName userSurname}
+                    $if isn't _Just examUserCsvActCourseNote
+                      \ (_{MsgExamUserCsvCourseNoteDeleted})
+                  |]
+                ExamUserCsvDeregisterData{..}
+                  -> registeredUserName' examUserCsvActRegistration
+            , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
+            , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
+            }
+            where
+              studyFeaturesWidget :: StudyFeaturesId -> Widget
+              studyFeaturesWidget featId = do
+                (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
+                [whamlet|
+                  $newline never
+                  _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
+                |]
+               
+              registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
+              registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
+                where
+                  Entity _ User{..} = view resultUser $ existing ! registration
+              
+              guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
+              guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
+                users <- E.select . E.from $ \user -> do
+                  E.where_ . E.and $ catMaybes
+                    [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
+                    , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
+                    , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
+                    , (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
+                    ]
+                  let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
+                        E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
+                             E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
+                  E.limit 2
+                  return (isCourseParticipant, user E.^. UserId)
+                case users of
+                  (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
+                    -> return (isPart, uid)
+                  [(E.Value isPart, E.Value uid)]
+                    -> return (isPart, uid)
+                  _other
+                    -> throwM ExamUserCsvExceptionNoMatchingUser
+
+              lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
+              lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
+                occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
+                case occIds of
+                  [occId] -> return occId
+                  _other  -> throwM ExamUserCsvExceptionNoMatchingOccurrence
+
+              lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
+              lookupStudyFeatures csv@ExamUserTableCsv{..} = do
+                uid <- view _2 <$> guessUser csv
+                studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
+                  E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
+                  E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
+                  E.where_ . E.and $ catMaybes 
+                    [ do
+                        field <- csvEUserField
+                        return . E.or $ catMaybes
+                          [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
+                          , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
+                          , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
+                          ]
+                    , do
+                        degree <- csvEUserDegree
+                        return . E.or $ catMaybes
+                          [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
+                          , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
+                          , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
+                          ]
+                    , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
+                    ]
+                  E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
+                       E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
+                       E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
+                  E.limit 2
+                  return $ studyFeatures E.^. StudyFeaturesId
+                case studyFeatures of
+                  [E.Value fid] -> return $ Just fid
+                  _other
+                    | is _Nothing csvEUserField
+                    , is _Nothing csvEUserDegree
+                    , is _Nothing csvEUserSemester
+                    -> return Nothing
+                  _other        -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
+
+      examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
+                                      & defaultPagesize PagesizeAll
+
+      postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
+      postprocess inp = do
+        (First (Just act), regMap) <- inp
+        let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
+        return (act, regSet)
+    over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
+
+  formResult registrationResult $ \case
+    (ExamUserDeregisterData, selectedRegistrations) -> do
+      nrDel <- runDB $ deleteWhereCount
+        [ ExamRegistrationId <-. Set.toList selectedRegistrations
+        ]
+      addMessageI Success $ MsgExamUsersDeregistered nrDel
+      redirect $ CExamR tid ssh csh examn EUsersR
+    (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
+      nrUpdated <- runDB $ updateWhereCount
+        [ ExamRegistrationId <-. Set.toList selectedRegistrations
+        ]
+        [ ExamRegistrationOccurrence =. occId
+        ]
+      addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
+      redirect $ CExamR tid ssh csh examn EUsersR
+
+  siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
+    setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
+    $(widgetFile "exam-users")

src/Handler/Health.hs

@@ -70,6 +70,9 @@ getHealthR = do
                   $of HealthWidgetMemcached (Just passed)
                     <dt .deflist__dt>_{MsgHealthWidgetMemcached}
                     <dd .deflist__dd>#{boolSymbol passed}
+                  $of HealthActiveJobExecutors (Just active)
+                    <dt .deflist__dt>_{MsgHealthActiveJobExecutors}
+                    <dd .deflist__dd>#{textPercent active 1}
                   $of _
           |]
         provideJson healthReports

src/Handler/Home.hs

@@ -39,10 +39,12 @@ homeOpenCourses = do
       colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
       colonnade = mconcat
         [ -- dbRow
-          sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
+          sortable (Just "term")   (i18nCell MsgTerm)
-            msgCell $ courseTerm course
+            $ \DBRow{ dbrOutput=Entity{entityVal = Course{..}} } ->
-        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
+              anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
-            msgCell $ courseSchool course
+        , sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
+            $ \DBRow{ dbrOutput=(Entity _ Course{..}) } ->
+              anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{unSchoolKey courseSchool}|]
         , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
             let tid = courseTerm      course
                 ssh = courseSchool    course
@@ -60,7 +62,7 @@ homeOpenCourses = do
                       [ ( "term"
                         , SortColumn $ \course -> course E.^. CourseTerm
                         )
-                      , ( "school"
+                      , ( "schoolshort"
                         , SortColumn $ \course -> course E.^. CourseSchool
                         )
                       , ( "course"
@@ -196,21 +198,39 @@ homeUpcomingExams uid = do
     examDBTable = DBTable{..}
       where
         -- for ease of refactoring:
-        queryCourse = $(sqlIJproj 2 1)
+        queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
-        queryExam   = $(sqlIJproj 2 2)
+        queryExam   = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
-        lensCourse  = _1
+        lensCourse     = _1
-        lensExam    = _2
+        lensExam       = _2
+        lensRegister   = _3 . _Just
+        lensOccurrence = _4 . _Just
 
-        dbtSQLQuery (course `E.InnerJoin` exam) = do
+        dbtSQLQuery ((course `E.InnerJoin` exam) `E.LeftOuterJoin` register `E.LeftOuterJoin` occurrence) = do
+          E.on $ register E.?. ExamRegistrationOccurrence E.==. E.just (occurrence E.?. ExamOccurrenceId)
+          E.on $ register E.?. ExamRegistrationExam       E.==. E.just (exam E.^. ExamId)
+                E.&&. register E.?. ExamRegistrationUser  E.==. E.just (E.val uid)
           E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
           E.where_ $ E.exists $ E.from $ \participant ->
             E.where_ $ participant E.^. CourseParticipantUser   E.==. E.val uid
               E.&&.    participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-          E.where_ $ E.isJust (exam E.^. ExamRegisterFrom)
+          let regToWithinFortnight = exam E.^. ExamRegisterTo    E.<=. E.just (E.val fortnight)
-                     E.&&.     exam E.^. ExamRegisterFrom  E.<=. E.just (E.val fortnight)
+                              E.&&.  exam E.^. ExamRegisterTo    E.>=. E.just (E.val now)
-          E.where_ $ E.isJust (exam E.^. ExamEnd)
+                              E.&&.  E.isNothing (register E.?. ExamRegistrationId)
-                     E.&&.     exam E.^. ExamEnd           E.>=. E.just (E.val now)
+              startExamFortnight   = exam E.^. ExamStart         E.<=. E.just (E.val fortnight)
-          return (course, exam)
+                              E.&&.  exam E.^. ExamStart         E.>=. E.just (E.val now)
+                              E.&&.  E.isJust (register E.?. ExamRegistrationId)
+              startOccurFortnight  = occurrence E.?. ExamOccurrenceStart E.<=. E.just (E.val fortnight)
+                              E.&&.  occurrence E.?. ExamOccurrenceStart E.>=. E.just (E.val now)
+                              E.&&.  E.isJust (register E.?. ExamRegistrationId)
+              earliestOccurrence = E.sub_select $ E.from $ \occ -> do
+                               E.where_ $ occ E.^. ExamOccurrenceExam E.==. exam E.^. ExamId
+                                   E.&&.  occ E.^. ExamOccurrenceStart E.>=. E.val now
+                               return $ E.min_ $ occ E.^. ExamOccurrenceStart
+              startEarliest = E.isNothing (occurrence E.?. ExamOccurrenceId)
+                        E.&&. earliestOccurrence E.<=. E.just (E.val fortnight)
+                        -- E.&&. earliestOccurrence E.>=. E.just (E.val now)
+          E.where_ $ regToWithinFortnight E.||. startExamFortnight E.||. startOccurFortnight E.||. startEarliest
+          return (course, exam, register, occurrence)
         dbtRowKey = queryExam >>> (E.^. ExamId)
         dbtProj r@DBRow{ dbrOutput } = do
           let Entity _ Exam{..}   = view lensExam   dbrOutput
@@ -231,7 +251,12 @@ homeUpcomingExams uid = do
               indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName
           , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
           , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
-          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
+          , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput } ->
+              if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
+                   -> cell $ formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd
+                 | Entity _ Exam{..} <- view lensExam dbrOutput
+                 , Just start <- examStart -> cell $ formatTimeRangeW SelFormatDateTime start examEnd
+                 | otherwise -> mempty
           {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems.
              Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers.
           , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do
@@ -251,14 +276,18 @@ homeUpcomingExams uid = do
                 | otherwise -> return mempty
             -}
           , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do
-              let Entity eId Exam{..} = view lensExam   dbrOutput
+              let Entity _ Exam{..} = view lensExam   dbrOutput
                   Entity _ Course{..} = view lensCourse dbrOutput
               mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True
-              isRegistered <- existsBy $ UniqueExamRegistration eId uid
+              let isRegistered = has lensRegister dbrOutput
-              let label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
+                  label   = bool MsgExamNotRegistered MsgExamRegistered isRegistered
                   examUrl = CExamR courseTerm courseSchool courseShorthand examName EShowR
               if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
                  | otherwise   -> return [whamlet|_{label}|]
+          , sortable (toNothingS "occurrence") (i18nCell MsgExamOccurrence) $ \DBRow{ dbrOutput } ->
+              if | Just (Entity _ ExamOccurrence{..}) <- preview lensOccurrence dbrOutput
+                   -> textCell examOccurrenceRoom
+                 | otherwise -> mempty
           ]
         dbtSorting = Map.fromList
           [ ("demo-both",     SortColumn $ queryCourse &&& queryExam >>> (\(_course,exam)-> exam E.^. ExamName))

src/Handler/Profile.hs

@@ -9,9 +9,11 @@ import Utils.Lens
 -- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
 import Data.Monoid (Any(..))
+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           Database.Esqueleto      ((^.))
 
 
@@ -26,6 +28,14 @@ data SettingsForm = SettingsForm
       , stgNotificationSettings :: NotificationSettings
       }
 
+data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKExamParticipant | NTKCorrector | NTKLecturer | NTKAdmin
+  deriving (Eq, Ord, Enum, Bounded, Generic, Typeable)
+instance Universe NotificationTriggerKind
+instance Finite NotificationTriggerKind
+
+embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel
+
+
 makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
 makeSettingForm template html = do
     (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
@@ -38,7 +48,7 @@ makeSettingForm template html = do
         <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
         <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
         <*  aformSection MsgFormBehaviour
-        <*> areq checkBoxField (fslI MsgDownloadFiles
+        <*> apopt checkBoxField (fslI MsgDownloadFiles
                                    & setTooltip MsgDownloadFilesTip
                                 ) (stgDownloadFiles <$> template)
         <*  aformSection MsgFormNotifications
@@ -76,9 +86,69 @@ makeSettingForm template html = do
 --     nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
 
 notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
-notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
+notificationForm template = wFormToAForm $ do
-  where
+  mbUid <- liftHandlerT maybeAuthId
-    nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
+  isAdmin <- hasReadAccessTo AdminR
+  
+  let
+    sectionIsHidden :: NotificationTriggerKind -> DB Bool
+    sectionIsHidden nt
+      | isAdmin
+      = return False
+      | Just uid <- mbUid
+      , NTKAdmin <- nt
+      = fmap not . E.selectExists . E.from $ \userAdmin ->
+          E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKLecturer <- nt
+      = fmap not . E.selectExists . E.from $ \userLecturer ->
+          E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKCorrector <- nt
+      = fmap not . E.selectExists . E.from $ \sheetCorrector ->
+          E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKCourseParticipant <- nt
+      = fmap not . E.selectExists . E.from $ \courseParticipant ->
+          E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
+      | Just uid <- mbUid
+      , NTKExamParticipant <- nt
+      = fmap not . E.selectExists . E.from $ \examRegistration ->
+          E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val uid
+      | otherwise
+      = return False
+  
+  ntHidden <- liftHandlerT . runDB
+            $ Set.fromList universeF
+            & Map.fromSet sectionIsHidden
+            & sequenceA
+            & fmap (!)
+  
+  let
+    nsForm nt
+      | maybe False ntHidden $ ntSection nt
+      = pure $ notificationAllowed def nt
+      | nt `elem` forcedTriggers
+      = aforced checkBoxField (fslI nt) (notificationAllowed def nt)
+      | otherwise
+      = apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
+
+    ntSection = \case
+      NTSubmissionRatedGraded     -> Just NTKCourseParticipant
+      NTSubmissionRated           -> Just NTKCourseParticipant
+      NTSheetActive               -> Just NTKCourseParticipant
+      NTSheetSoonInactive         -> Just NTKCourseParticipant
+      NTSheetInactive             -> Just NTKLecturer
+      NTCorrectionsAssigned       -> Just NTKCorrector
+      NTCorrectionsNotDistributed -> Just NTKLecturer
+      NTUserRightsUpdate          -> Just NTKAll
+      NTUserAuthModeUpdate        -> Just NTKAll
+      NTExamResult                -> Just NTKExamParticipant
+      -- _other                      -> Nothing
+
+    forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
+    
+  aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
 
 
 data ButtonResetTokens = BtnResetTokens

src/Handler/Sheet.hs

@@ -899,21 +899,22 @@ correctorInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
       fetchSheetId tid csh ssh shn
-    invitationSubject Sheet{..} _ = do
+    invitationSubject (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
-    invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
+    invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
     invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ JunctionSheetCorrector load state
+    invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ())
-    invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
+    invitationInsertHook _ _ _ _ = id
-    invitationUltDest Sheet{..} _ = do
+    invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
+    invitationUltDest (Entity _ Sheet{..}) _ = do
       Course{..} <- get404 sheetCourse
       return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
 

src/Handler/Submission.hs

@@ -89,19 +89,19 @@ submissionUserInvitationConfig = InvitationConfig{..}
       Course{..} <- getJust sheetCourse
       cID <- encrypt subId
       return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
       subId <- decrypt cID
       bool notFound (return subId) =<< existsKey subId
-    invitationSubject Submission{..} _ = do
+    invitationSubject (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
       return . SomeMessage $ MsgMailSubjectSubmissionUserInvitation courseTerm courseSchool courseShorthand sheetName
-    invitationHeading Submission{..} _ = do
+    invitationHeading (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       return . SomeMessage $ MsgSubmissionUserInviteHeading sheetName
     invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSubmissionUserInviteExplanation}|]
-    invitationTokenConfig Submission{..} _ = do
+    invitationTokenConfig (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
       itAuthority <- liftHandlerT requireAuthId
@@ -110,14 +110,15 @@ submissionUserInvitationConfig = InvitationConfig{..}
           itStartsAt = Nothing
       return InvitationTokenConfig{..}
     invitationRestriction _ _ = return Authorized
-    invitationForm _ _ _ = pure JunctionSubmissionUser
+    invitationForm _ _ _ = pure (JunctionSubmissionUser, ())
-    invitationSuccessMsg Submission{..} _ = do
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       return . SomeMessage $ MsgSubmissionUserInvitationAccepted sheetName
-    invitationUltDest Submission{..} (Entity _ SubmissionUser{..}) = do
+    invitationUltDest (Entity subId Submission{..}) _ = do
       Sheet{..} <- getJust submissionSheet
       Course{..} <- getJust sheetCourse
-      cID <- encrypt submissionUserSubmission
+      cID <- encrypt subId
       return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
 
 

src/Handler/Term.hs

@@ -187,7 +187,7 @@ termEditHandler term = do
           -- term <- runDB $ get $ TermKey termName
           runDB $ do
             repsert tid res
-            audit' . TransactionTermEdit $ unTermKey tid
+            audit $ TransactionTermEdit tid
 -- VOR INTERNATIONALISIERUNG:
 --           let tid = termToText $ termName res
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."

src/Handler/Tutorial.hs

@@ -1,6 +1,8 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Handler.Tutorial where
+module Handler.Tutorial
+  ( module Handler.Tutorial
+  ) where
 
 import Import
 import Handler.Utils
@@ -28,6 +30,8 @@ import Utils.Lens
 import Data.Aeson hiding (Result(..))
 import Text.Hamlet (ihamlet)
 
+import Handler.Tutorial.Users as Handler.Tutorial
+
 {-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
 
 
@@ -249,21 +253,22 @@ tutorInvitationConfig = InvitationConfig{..}
     invitationRoute (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
-    invitationResolveFor = do
+    invitationResolveFor _ = do
       Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
       fetchTutorialId tid csh ssh tutn
-    invitationSubject Tutorial{..} _ = do
+    invitationSubject (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
-    invitationHeading Tutorial{..} _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
+    invitationHeading (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgTutorInviteHeading tutorialName
     invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgTutorInviteExplanation}|]
     invitationTokenConfig _ _ = do
       itAuthority <- liftHandlerT requireAuthId
       return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
     invitationRestriction _ _ = return Authorized
-    invitationForm _ _ _ = pure JunctionTutor
+    invitationForm _ _ _ = pure (JunctionTutor, ())
-    invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
+    invitationInsertHook _ _ _ _ = id
-    invitationUltDest Tutorial{..} _ = do
+    invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
+    invitationUltDest (Entity _ Tutorial{..}) _ = do
       Course{..} <- get404 tutorialCourse
       return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
 

src/Handler/Tutorial/Users.hs

@@ -0,0 +1,73 @@
+module Handler.Tutorial.Users
+  ( getTUsersR, postTUsersR
+  ) where
+
+import Import
+
+import Utils.Lens
+import Utils.Form
+-- import Utils.DB
+import Handler.Utils
+import Handler.Utils.Tutorial
+import Handler.Utils.Table.Columns
+import Database.Persist.Sql (deleteWhereCount)
+
+import qualified Data.CaseInsensitive as CI
+import Data.Function ((&))
+
+import qualified Data.Set as Set
+
+import qualified Database.Esqueleto as E
+
+import Handler.Course.Users
+
+
+data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+
+instance Universe TutorialUserAction
+instance Finite TutorialUserAction
+nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''TutorialUserAction id
+
+
+getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
+getTUsersR = postTUsersR
+postTUsersR tid ssh csh tutn = do
+  (Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
+    tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
+    let colChoices  = mconcat
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , colUserName
+          , colUserEmail
+          , colUserMatriclenr
+          , colUserDegreeShort
+          , colUserField
+          , colUserSemester
+          ]
+        psValidator = def
+          & defaultSortingByName
+          & restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+        isInTut q = E.exists . E.from $ \tutorialParticipant ->
+          E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
+               E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
+    cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+    table <- makeCourseUserTable cid isInTut colChoices psValidator
+    return (tut, table)
+
+  formResult participantRes $ \case
+    (TutorialUserSendMail, selectedUsers) -> do
+        cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
+        redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
+    (TutorialUserDeregister,selectedUsers) -> do
+        nrDel <- runDB $ deleteWhereCount
+          [ TutorialParticipantTutorial ==. tutid
+          , TutorialParticipantUser <-. Set.toList selectedUsers
+          ]
+        addMessageI Success $ MsgTutorialUsersDeregistered nrDel
+        redirect $ CTutorialR tid ssh csh tutn TUsersR
+
+  let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
+  siteLayoutMsg heading $ do
+    setTitleI heading
+    $(widgetFile "tutorial-participants")

src/Handler/Users.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
 module Handler.Users where
 
 import Import
@@ -5,6 +7,11 @@ import Import
 import Jobs
 -- import Data.Text
 import Handler.Utils
+import Handler.Utils.Tokens
+import Handler.Utils.Users
+import Handler.Utils.Invitations
+
+import qualified Auth.LDAP as Auth
 
 import Utils.Lens
 
@@ -18,6 +25,13 @@ import qualified Database.Esqueleto.Utils as E
 
 import Handler.Profile (makeProfileData)
 
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+
+import qualified Data.ByteString.Base64 as Base64
+
+import Text.Hamlet (ihamlet)
+import Data.Aeson hiding (Result(..))
+
 
 hijackUserForm :: CryptoUUIDUser -> Form ()
 hijackUserForm cID csrf = do
@@ -45,6 +59,7 @@ getUsersR = do
 --       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
 --           (AdminUserR <$> encrypt uid)
 --           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
+      , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
       , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
           schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
             E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
@@ -106,6 +121,9 @@ getUsersR = do
           , ( "matriculation"
             , SortColumn $ \user -> user E.^. UserMatrikelnummer
             )
+          , ( "auth-ldap"
+            , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
+            )
           ]
       , dbtFilter    = Map.fromList -- OverloadedLists does not work with the templates
           [ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
@@ -117,6 +135,12 @@ getUsersR = do
                  | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                  | otherwise         -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
             )
+          , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
+                | Just crit <- getLast criterion
+                  -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
+                | otherwise
+                  -> E.true
+            )
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> let schools = E.valList (Set.toList criterion) in
@@ -134,7 +158,7 @@ getUsersR = do
           [ prismAForm (singletonFilter "user-search")    mPrev $ aopt textField  (fslI MsgName)
           -- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr)
           , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField  (fslI MsgMatrikelNr)
-
+          , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` radioFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
           , prismAForm (singletonFilter "school" )        mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
@@ -160,6 +184,18 @@ postAdminHijackUserR cID = do
   maybe (redirect UsersR) return ret
 
 
+data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
+instance Universe ButtonAuthMode
+instance Finite ButtonAuthMode
+
+nullaryPathPiece ''ButtonAuthMode $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonAuthMode id
+
+instance Button UniWorX ButtonAuthMode where
+  btnClasses _ = [BCIsButton]
+
+
 getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
 getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
@@ -196,9 +232,13 @@ postAdminUserR uuid = do
           let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
                         (,,) <$> pure sid <*> resAdmin <*> resLecturer
           return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
+        userAuthenticationForm :: Form ButtonAuthMode
+        userAuthenticationForm = buttonForm' $ if
+          | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
+          | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
     let userRightsAction changes = do
-          void . runDB $
+          runDBJobs $ do
-            forM changes $ \(sid, userAdmin, userLecturer) ->
+            forM_ changes $ \(sid, userAdmin, userLecturer) ->
               if Set.notMember sid adminSchools
                 then return ()
                 else do
@@ -209,21 +249,67 @@ postAdminUserR uuid = do
                     then void . insertUnique $ UserLecturer uid sid
                     else deleteBy $ UniqueSchoolLecturer uid sid
                 -- Note: deleteWhere would not work well here since we filter by adminSchools
-          queueJob' . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
+            queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
           addMessageI Info MsgAccessRightsSaved
-    ((result, formWidget),formEnctype) <- runFormPost userRightsForm
+          redirect $ AdminUserR uuid
-    let form = wrapForm formWidget def
+          
+        userAuthenticationAction = \case
+          BtnAuthLDAP -> do
+            let 
+              campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
+              campusHandler _ = mzero
+            campusResult <- runMaybeT . handle campusHandler $ do
+                (Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
+                void . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
+            case campusResult of
+              Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
+              _other
+                | is _AuthLDAP userAuthentication
+                  -> addMessageI Info MsgAuthLDAPAlreadyConfigured
+              Just () -> do
+                runDBJobs $ do
+                  update uid [ UserAuthentication =. AuthLDAP ]
+                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
+                  
+                addMessageI Success MsgAuthLDAPConfigured
+            redirect $ AdminUserR uuid
+          BtnAuthPWHash -> do
+            if
+              | is _AuthPWHash userAuthentication
+                -> addMessageI Info MsgAuthPWHashAlreadyConfigured
+              | otherwise
+                -> do
+                  runDBJobs $ do
+                    update uid [ UserAuthentication =. AuthPWHash "" ]
+                    queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
+                    queueDBJob $ JobSendPasswordReset uid
+
+                  addMessageI Success MsgAuthPWHashConfigured
+            redirect $ AdminUserR uuid
+          BtnPasswordReset -> do
+            queueJob' $ JobSendPasswordReset uid
+            addMessageI Success MsgPasswordResetQueued
+            redirect $ AdminUserR uuid
+    ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
+    ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
+    let rightsForm = wrapForm rightsFormWidget def
           { formAction = Just . SomeRoute $ AdminUserR uuid
-          , formEncoding = formEnctype
+          , formEncoding = rightsFormEnctype
           }
-    formResult result userRightsAction
+        authForm = wrapForm authFormWidget def
+          { formAction = Just . SomeRoute $ AdminUserR uuid
+          , formEncoding = authFormEnctype
+          , formSubmit = FormNoSubmit
+          }
+    formResult rightsResult userRightsAction
+    formResult authResult userAuthenticationAction
     let heading =
-          [whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
+          [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
     -- Delete Button needed in data-delete
-    (btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
+    (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
-    let btnForm = wrapForm btnWgt def
+    let deleteForm = wrapForm deleteWgt def
           { formAction   = Just $ SomeRoute $ AdminUserDeleteR uuid
-          , formEncoding = btnEnctype
+          , formEncoding = deleteEnctype
           , formSubmit   = FormNoSubmit
           }
     userDataWidget <- runDB $ makeProfileData $ Entity uid user
@@ -300,3 +386,149 @@ deleteUser duid = do
           E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
                E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
 
+
+getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html
+getUserPasswordR = postUserPasswordR
+postUserPasswordR cID = do
+  tUid <- decrypt cID
+  User{..} <- runDB $ get404 tUid
+  PWHashConf{..} <- getsYesod $ view _appAuthPWHash
+  isModal <- hasCustomHeader HeaderIsModal
+
+  isAdmin <- hasWriteAccessTo $ AdminUserR cID
+
+  requireCurrent <- maybeT (return True) $ asum
+    [ False <$ guard (isn't _AuthPWHash userAuthentication)
+    , False <$ guard isAdmin
+    , do
+        authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions
+        unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
+          invalidArgsI [MsgUnauthorizedPasswordResetToken]
+        return False
+    ]
+
+  ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
+    currentResult <- if
+      | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
+      , requireCurrent
+        -> wreq
+             (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
+             (fslI MsgCurrentPassword)
+             Nothing
+      | otherwise
+        -> return $ FormSuccess ()
+
+    newResult <- do
+      resA <- wreq passwordField (fslI MsgNewPassword) Nothing
+      wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat) Nothing
+
+    return . fmap encodeUtf8 $ currentResult *> newResult
+
+  formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
+    newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
+    liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
+    tell . pure =<< messageI Success MsgPasswordChangedSuccess
+
+  siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $
+    wrapForm passFormWidget def
+      { formAction = Just . SomeRoute $ UserPasswordR cID
+      , formEncoding = passEnctype
+      , formAttrs = [ asyncSubmitAttr | isModal ]
+      }
+
+
+instance IsInvitableJunction UserLecturer where
+  type InvitationFor UserLecturer = School
+  data InvitableJunction UserLecturer = JunctionUserLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationDBData UserLecturer = InvDBDataUserLecturer
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  data InvitationTokenData UserLecturer = InvTokenDataUserLecturer
+    { invTokenUserLecturerSchool :: SchoolShorthand
+    }
+    deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+  _InvitableJunction = iso
+    (\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer))
+    (\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..})
+
+instance ToJSON (InvitableJunction UserLecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+instance FromJSON (InvitableJunction UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
+
+instance ToJSON (InvitationDBData UserLecturer) where
+  toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationDBData UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
+
+instance ToJSON (InvitationTokenData UserLecturer) where
+  toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+  toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+instance FromJSON (InvitationTokenData UserLecturer) where
+  parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
+
+lecturerInvitationConfig :: InvitationConfig UserLecturer
+lecturerInvitationConfig = InvitationConfig{..}
+  where
+    invitationRoute _ _ = return AdminLecturerInviteR
+    invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool
+    invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName
+    invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName
+    invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|]
+    invitationTokenConfig _ _ = do
+      itAuthority <- liftHandlerT requireAuthId
+      return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
+    invitationRestriction _ _ = return Authorized
+    invitationForm _ _ _ = pure $ (JunctionUserLecturer, ())
+    invitationInsertHook _ _ _ _ = id
+    invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName
+    invitationUltDest (Entity ssh _) _ = do
+      currentTerm <- E.select . E.from $ \term -> do
+        E.where_ $ term E.^. TermActive
+        E.orderBy [E.desc $ term E.^. TermName]
+        E.limit 1
+        return $ term E.^. TermId
+      return . SomeRoute $ case currentTerm of
+        [E.Value tid] -> TermSchoolCourseListR tid ssh
+        _other        -> CourseListR
+      
+      
+getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html
+getAdminNewLecturerInviteR = postAdminNewLecturerInviteR
+postAdminNewLecturerInviteR = do
+  uid <- requireAuthId
+  userSchools <- runDB . E.select . E.from $ \userAdmin -> do
+    E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+    return $ userAdmin E.^. UserAdminSchool
+  
+  ((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
+    school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing
+    users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
+    return $ (,) <$> school <*> users
+
+  formResultModal invitesResult UsersR $ \(schoolId, users) -> do
+    let (emails, uids) = partitionEithers $ Set.toList users
+    lift . runDBJobs $ do
+      forM_ uids $ \lecId ->
+        void . insertUnique $ UserLecturer lecId schoolId
+
+      sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ]
+
+    unless (null emails) $ 
+      tell . pure <=< messageI Success . MsgLecturersInvited $ length emails
+    unless (null uids) $ 
+      tell . pure <=< messageI Success . MsgLecturersAdded $ length uids
+
+  siteLayoutMsg MsgLecturerInviteHeading $ do
+    setTitleI MsgLecturerInviteHeading
+    wrapForm invitesWgt def
+      { formEncoding = invitesEncoding
+      , formAction = Just $ SomeRoute AdminNewLecturerInviteR
+      }
+
+getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html
+getAdminLecturerInviteR = postAdminLecturerInviteR
+postAdminLecturerInviteR = invitationR lecturerInvitationConfig

src/Handler/Utils/Csv.hs

@@ -14,11 +14,17 @@ module Handler.Utils.Csv
   , toCsvRendered
   ) where
 
-import Import hiding (Header)
+import Import hiding (Header, mapM_)
 
 import Data.Csv
 import Data.Csv.Conduit
 
+import Data.Function ((&))
+import Control.Monad (mapM_)
+
+-- import qualified Data.Csv.Util as Csv
+import qualified Data.Csv.Parser as Csv
+
 import qualified Data.Conduit.List as C
 import qualified Data.Conduit.Combinators as C (sourceLazy)
 
@@ -26,20 +32,84 @@ import qualified Data.Map as Map
 import qualified Data.Vector as Vector
 import qualified Data.HashMap.Strict as HashMap
 
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+
+import qualified Data.Attoparsec.ByteString.Lazy as A
+
 
 deriving instance Typeable CsvParseError
 instance Exception CsvParseError
 
 
-typeCsv :: ContentType
+typeCsv, typeCsv' :: ContentType
 typeCsv = "text/csv"
+typeCsv' = BS.intercalate "; " [typeCsv, "charset=UTF-8", "header=present"]
 
 extensionCsv :: Extension
 extensionCsv = fromMaybe "csv" $ listToMaybe [ ext | (ext, mime) <- Map.toList mimeMap, mime == typeCsv ]
 
 
-decodeCsv :: (MonadThrow m, FromNamedRecord csv) => Conduit ByteString m csv
+decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv
-decodeCsv = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions
+decodeCsv = transPipe throwExceptT $ do
+  testBuffer <- accumTestBuffer LBS.empty
+  mapM_ leftover $ LBS.toChunks testBuffer
+
+  let decodeOptions = defaultDecodeOptions
+        & guessDelimiter testBuffer
+  $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|]
+  
+  fromNamedCsv decodeOptions
+  where
+    testBufferSize = 4096
+    accumTestBuffer acc
+      | LBS.length acc >= testBufferSize = return acc
+      | otherwise = do
+        frag <- await
+        case frag of
+          Nothing -> return acc
+          Just frag' -> accumTestBuffer (acc <> LBS.fromStrict frag')
+
+    guessDelimiter testBuffer
+      | Just firstDQuote <- doubleQuote `LBS.elemIndex` testBuffer
+      = if
+          | firstDQuote /= 0
+            -> \x -> x { Csv.decDelimiter = testBuffer `LBS.index` pred firstDQuote }
+          | A.Done unused _ <- A.parse quotedField testBuffer
+            -> case A.parse endOfLine unused of
+              A.Fail{}
+                | Just (nextChar, _) <- LBS.uncons unused
+                  -> \x -> x { Csv.decDelimiter = nextChar }
+              _other -> guessDelimiter $ LBS.take firstDQuote testBuffer <> unused
+          | otherwise
+            -> id -- Parsing of something, which should be a quoted field, failed; bail now
+      | A.Done _ ls <- A.parse (A.many1 $ A.manyTill A.anyWord8 endOfLine) testBuffer
+      , (h:hs) <- filter (not . Map.null) $ map (fmap getSum . Map.unionsWith mappend . map (flip Map.singleton $ Sum 1)) ls
+      , Just equals <- fromNullable $ Map.filterWithKey (\c n -> all ((== Just n) . Map.lookup c) hs) h
+      , let maxH = maximum equals
+      , [d] <- filter ((== Just maxH) . flip Map.lookup (toNullable equals)) . Map.keys $ toNullable equals
+      = \x -> x { Csv.decDelimiter = d }
+      | otherwise
+      = id
+
+
+    quotedField :: A.Parser () -- We don't care about the return value
+    quotedField = void . Csv.field $ Csv.decDelimiter defaultDecodeOptions -- We can use comma as a separator, because we know that the field we're trying to parse is quoted and so does not rely on the delimiter
+
+
+    endOfLine :: A.Parser ()
+    endOfLine = asum
+      [ void $ A.word8 newline
+      , mapM_ A.word8 [cr, newline]
+      , void $ A.word8 cr
+      ]
+
+    doubleQuote, newline, cr :: Word8
+    doubleQuote = 34
+    newline = 10
+    cr = 13
+
+      
 
 encodeCsv :: ( ToNamedRecord csv
              , DefaultOrdered csv
@@ -57,7 +127,7 @@ respondCsv :: ( ToNamedRecord csv
               )
            => Source (HandlerT site IO) csv
            -> HandlerT site IO TypedContent
-respondCsv src = respondSource typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+respondCsv src = respondSource typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
 
 respondCsvDB :: ( ToNamedRecord csv
                 , DefaultOrdered csv
@@ -65,10 +135,11 @@ respondCsvDB :: ( ToNamedRecord csv
                 )
              => Source (YesodDB site) csv
              -> HandlerT site IO TypedContent
-respondCsvDB src = respondSourceDB typeCsv $ src .| encodeCsv .| awaitForever sendChunk
+respondCsvDB src = respondSourceDB typeCsv' $ src .| encodeCsv .| awaitForever sendChunk
 
 fileSourceCsv :: ( FromNamedRecord csv
                  , MonadResource m
+                 , MonadLogger m
                  )
               => FileInfo
               -> Source m csv

src/Handler/Utils/DateTime.hs

@@ -31,36 +31,9 @@ import qualified Data.Set as Set
 import Data.Time.Clock.System (systemEpochDay)
 
 
-
+-------------
---------------------
+-- UTCTime --
--- NominalDiffTime
+-------------
-
--- | One hour in 'NominalDiffTime'.
-nominalHour :: NominalDiffTime
-nominalHour = 3600
-
--- | One minute in 'NominalDiffTime'.
-nominalMinute :: NominalDiffTime
-nominalMinute= 60
-
-formatDiffDays :: NominalDiffTime -> Text
-formatDiffDays t
-  | t > nominalDay    = inDays    <> "d"
-  | t > nominalHour   = inHours   <> "h"
-  | t > nominalMinute = inMinutes <> "m"
-  | otherwise         = tshow $ roundToDigits 0 t
-  where
-    convertBy :: NominalDiffTime -> Double
-    convertBy len = realToFrac $ roundToDigits 1 $ t / len
-    inDays    = tshow $ convertBy nominalDay
-    inHours   = tshow $ convertBy nominalHour
-    inMinutes = tshow $ convertBy nominalMinute
-
-
-
-------------
--- UTCTime
-
 
 utcToLocalTime :: UTCTime -> LocalTime
 utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@@ -198,6 +171,20 @@ dateTimeFormatOptions sel = do
   optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel
 
 
+formatDiffDays :: NominalDiffTime -> Text
+formatDiffDays t
+  | t > nominalDay    = inDays    <> "d"
+  | t > nominalHour   = inHours   <> "h"
+  | t > nominalMinute = inMinutes <> "m"
+  | otherwise         = tshow $ roundToDigits 0 t
+  where
+    convertBy :: NominalDiffTime -> Double
+    convertBy len = realToFrac $ roundToDigits 1 $ t / len
+    inDays    = tshow $ convertBy nominalDay
+    inHours   = tshow $ convertBy nominalHour
+    inMinutes = tshow $ convertBy nominalMinute
+
+
 setYear :: Integer -> Day -> Day
 setYear year date = fromGregorian year month day
   where

src/Handler/Utils/Form.hs

@@ -169,9 +169,34 @@ linkButton defWdgt lbl cls url = do
 -- Interactive fieldset --
 --------------------------
 
+optionalAction :: AForm Handler a
+               -> FieldSettings UniWorX
+               -> Maybe Bool
+               -> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
+optionalAction justAct fs@FieldSettings{..} defActive csrf = do
+  (doRes, doView) <- mpopt checkBoxField fs defActive
+  (actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct
+
+  let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
+
+  return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
+  
+optionalActionA :: AForm Handler a
+                -> FieldSettings UniWorX
+                -> Maybe Bool
+                -> AForm Handler (Maybe a)
+optionalActionA justAct fs defActive = formToAForm $ optionalAction justAct fs defActive mempty
+
+optionalActionW :: AForm Handler a
+                -> FieldSettings UniWorX
+                -> Maybe Bool
+                -> WForm Handler (FormResult (Maybe a))
+optionalActionW justAct fs defAction = aFormToWForm $ optionalActionA justAct fs defAction
+
+
 multiAction :: forall action a.
                ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
-            => Map action (AForm (HandlerT UniWorX IO) a)
+            => Map action (AForm Handler a)
             -> FieldSettings UniWorX
             -> Maybe action
             -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
@@ -858,16 +883,34 @@ boolField = Field
 
 
 
-funcForm :: forall k v m.
+sectionedFuncForm  :: forall k v m sec.
-            ( Finite k, Ord k
+                      ( Finite k, Ord k
-            , MonadHandler m
+                      , MonadHandler m
-            , HandlerSite m ~ UniWorX
+                      , HandlerSite m ~ UniWorX
-            )
+                      , RenderMessage UniWorX sec
-         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+                      , Ord sec
-funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
+                      )
+                   => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
   where
     funcForm' :: AForm m (k -> v)
-    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
+    funcForm' = Set.fromList universeF
+              & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
+              & fmap (Map.fromSet mkForm)
+              & fmap sequenceA
+              & Map.foldrWithKey accSections (pure Map.empty)
+              & fmap (!)
+    accSections mSection optsForm acc = wFormToAForm $ do
+      (res, fs) <- wFormFields $ aFormToWForm optsForm
+      if
+        | not $ null fs
+        , Just section <- mSection
+          -> wformSection section
+        | otherwise
+          -> return ()
+      lift $ tell fs
+      aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
+  
     funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
     funcFieldView (res, fvInput) = do
       mr <- getMessageRender
@@ -882,6 +925,15 @@ funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAF
     -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
 
 
+funcForm :: forall k v m.
+            ( Finite k, Ord k
+            , MonadHandler m
+            , HandlerSite m ~ UniWorX
+            )
+         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
+funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
+
+
 
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
@@ -1003,3 +1055,51 @@ multiUserField onlySuggested suggestions = Field{..}
               [] -> return $ Left email
               [E.Value uid] -> return $ Right uid
               _other -> fail "Ambiguous e-mail addr"
+
+examResultField :: forall m res.
+                   ( MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   , PathPiece res
+                   )
+                => Field m res -> Field m (ExamResult' res)
+examResultField innerField = Field
+  { fieldEnctype = UrlEncoded <> fieldEnctype innerField
+  , fieldParse = \ts fs -> if
+      | [t] <- ts
+      , Just res <- fromPathPiece t
+      , is _ExamNoShow res || is _ExamVoided res
+        -> return . Right $ Just res
+      | otherwise
+        -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
+  , fieldView = \theId name attrs val isReq -> do
+      innerId <- newIdent
+      let
+        val' :: ExamResult' (Either Text res)
+        val' = either (ExamAttended . Left) (fmap Right) val
+        innerVal :: Either Text res
+        innerVal = val >>= maybe (Left "") return . preview _ExamAttended
+      [whamlet|
+        $newline never
+        <div>
+          <select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
+            <option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
+            <option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
+            <option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
+          <fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
+            ^{fieldView innerField innerId name attrs innerVal False}
+      |]
+  }
+
+examGradeField :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  )
+               => Field m ExamGrade
+examGradeField = hoistField liftHandlerT $ selectField optionsFinite
+
+examPassedField :: forall m.
+                   ( MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   )
+                => Field m ExamPassed
+examPassedField = hoistField liftHandlerT $ selectField optionsFinite

src/Handler/Utils/Invitations.hs

@@ -40,6 +40,7 @@ import Data.Typeable
 class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
       , ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
       , FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
+      , Eq (InvitationDBData junction)
       , PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX)
       , Typeable junction
       ) => IsInvitableJunction junction where
@@ -111,30 +112,32 @@ invRef = toJSON . InvRef @junction
 -- | Configuration needed for creating and accepting/declining `Invitation`s
 --
 -- It is advisable to define this once per `junction` in a global constant
-data InvitationConfig junction = InvitationConfig
+data InvitationConfig junction = forall formCtx. InvitationConfig
-  { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
+  { invitationRoute       :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX)
     -- ^ Which route calls `invitationR` for this kind of invitation?
-  , invitationResolveFor  :: YesodDB UniWorX (Key (InvitationFor junction))
+  , invitationResolveFor  :: InvitationTokenData junction -> DB (Key (InvitationFor junction))
     -- ^ Monadically resolve `InvitationFor` during `inviteR`
     --
-    -- Usually from `requireBearerToken` or `getCurrentRoute`
+    -- Usually from `getCurrentRoute`
-  , invitationSubject     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
+  , invitationSubject     :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
     -- ^ Subject of the e-mail which sends the token to the user
-  , invitationHeading     :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
+  , invitationHeading     :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
     -- ^ Heading of the page which allows the invitee to accept/decline the invitation (`invitationR`
-  , invitationExplanation :: InvitationFor junction -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
+  , invitationExplanation :: Entity (InvitationFor junction) -> InvitationData junction -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
     -- ^ Explanation of what kind of invitation this is (used both in the e-mail and in `invitationR`)
-  , invitationTokenConfig :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX InvitationTokenConfig
+  , invitationTokenConfig :: Entity (InvitationFor junction) -> InvitationData junction -> DB InvitationTokenConfig
     -- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
-  , invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
+  , invitationRestriction :: Entity (InvitationFor junction) -> InvitationData junction -> DB AuthResult
     -- ^ Additional restrictions to check before allowing an user to redeem an invitation token
-  , invitationForm        :: InvitationFor junction -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction)
+  , invitationForm        :: Entity (InvitationFor junction) -> InvitationData junction -> Key User -> AForm (YesodDB UniWorX) (InvitableJunction junction, formCtx)
     -- ^ Assimilate the additional data entered by the redeeming user
-  , invitationSuccessMsg  :: InvitationFor junction -> Entity junction         -> YesodDB UniWorX (SomeMessage UniWorX)
+  , invitationInsertHook  :: forall a. Entity (InvitationFor junction) -> InvitationData junction -> junction -> formCtx -> (DB a -> DB a)
+    -- ^ Perform additional actions before or after insertion of the junction into the database
+  , invitationSuccessMsg  :: Entity (InvitationFor junction) -> Entity junction         -> DB (SomeMessage UniWorX)
     -- ^ What to tell the redeeming user after accepting the invitation
-  , invitationUltDest     :: InvitationFor junction -> Entity junction         -> YesodDB UniWorX (SomeRoute UniWorX)
+  , invitationUltDest     :: Entity (InvitationFor junction) -> Entity junction         -> DB (SomeRoute UniWorX)
     -- ^ Where to redirect the redeeming user after accepting the invitation
-  } deriving (Generic, Typeable)
+  }
 
 -- | Additional configuration needed for an invocation of `bearerToken`
 data InvitationTokenConfig = InvitationTokenConfig
@@ -177,36 +180,50 @@ sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lif
   where
     determineExists :: Conduit (Invitation' junction)
                                (YesodJobDB UniWorX)
-                               (Either (InvitationId, InvitationData junction) (Invitation' junction))
+                               (Invitation' junction)
     determineExists
       | is _Just (ephemeralInvitation @junction)
-      = C.map Right
+      = C.map id
       | otherwise
-      = C.mapM $ \inp@(email, fid, dat) ->
+      = awaitForever $ \inp@(email, fid, view _InvitationData -> (dat, _)) -> do
-          maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
+          dbEntry <- lift . getBy $ UniqueInvitation email (invRef @junction fid)
+          case dbEntry of
+            Just (Entity _ Invitation{invitationData})
+              | Just dbData <- decode invitationData
+              , dbData == dat
+                -> return ()
+            Just (Entity invId _)
+              -> lift (delete invId) >> yield inp
+            Nothing
+              -> yield inp
+      where
+        decode invData
+          = case fromJSON invData of
+              JSON.Success dbData -> return dbData
+              JSON.Error   str    -> fail $ "Could not decode invitationData: " <> str
 
-    sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
+    sinkInvitations' :: [Invitation' junction]
                      -> YesodJobDB UniWorX ()
-    sinkInvitations' (partitionEithers -> (existing, new)) = do
+    sinkInvitations' new = do
       when (is _Nothing (ephemeralInvitation @junction)) $ do
         insertMany_ $ map (\(email, fid, dat) -> Invitation email (invRef @junction fid) (toJSON $ dat ^. _invitationDBData)) new
-        forM_ existing $ \(iid, dat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
+        -- forM_ existing $ \(iid, oldDat) -> update iid [ InvitationData =. toJSON (dat ^. _invitationDBData) ]
       forM_ new $ \(jInvitee, fid, dat) -> do
         app <- getYesod
         let mr = renderMessage app $ NonEmpty.toList appLanguages
         ur <- getUrlRenderParams
 
-        fRec <- get404 fid
+        fEnt <- Entity fid <$> get404 fid
 
         jInviter <- liftHandlerT requireAuthId
-        route <- mapReaderT liftHandlerT $ invitationRoute (Entity fid fRec) dat
+        route <- mapReaderT liftHandlerT $ invitationRoute fEnt dat
-        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec dat
+        InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fEnt dat
         protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
         let token = protoToken & tokenRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
         jwt <- encodeToken token
         jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece jwt)])
-        jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fRec dat
+        jInvitationSubject <- fmap mr . mapReaderT liftHandlerT $ invitationSubject fEnt dat
-        let jInvitationExplanation = invitationExplanation fRec dat (toHtml . mr) ur
+        let jInvitationExplanation = invitationExplanation fEnt dat (toHtml . mr) ur
 
         queueDBJob JobInvitation{..}
 
@@ -265,12 +282,12 @@ invitationR' :: forall junction m.
              -> m Html
 -- | Generic handler for incoming invitations
 invitationR' InvitationConfig{..} = liftHandlerT $ do
-  InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
+  InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
   invitee <- requireAuthId
   Just cRoute <- getCurrentRoute
 
   (tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
-    Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
+    fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
     dbData <- case ephemeralInvitation @junction of
       Nothing -> do
         Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
@@ -281,9 +298,9 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
     let
       iData :: InvitationData junction
       iData = review _InvitationData (dbData, itData)
-    guardAuthResult =<< invitationRestriction fRec iData
+    guardAuthResult =<< invitationRestriction fEnt iData
     ((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
-      dataRes <- aFormToWForm $ invitationForm fRec iData invitee
+      dataRes <- aFormToWForm $ invitationForm fEnt iData invitee
       btnRes <- aFormToWForm . disambiguateButtons $ combinedButtonField (BtnInviteAccept : [ BtnInviteDecline | is _Nothing $ ephemeralInvitation @junction ]) (fslI MsgInvitationAction & bool id (setTooltip MsgInvitationActionTip) (is _Nothing $ ephemeralInvitation @junction))
       case btnRes of
         FormSuccess BtnInviteDecline -> return $ FormSuccess Nothing
@@ -291,22 +308,23 @@ invitationR' InvitationConfig{..} = liftHandlerT $ do
 
     MsgRenderer mr <- getMsgRenderer
     ur <- getUrlRenderParams
-    heading <- invitationHeading fRec iData
+    heading <- invitationHeading fEnt iData
-    let explanation = invitationExplanation fRec iData (toHtml . mr) ur
+    let explanation = invitationExplanation fEnt iData (toHtml . mr) ur
 
     fmap (, (dataWidget, dataEnctype), heading, explanation) . formResultMaybe dataRes $ \case
       Nothing -> do
         addMessageI Info MsgInvitationDeclined
         deleteBy . UniqueInvitation itEmail $ invRef @junction fid
         return . Just $ SomeRoute HomeR
-      Just jData -> do
+      Just (jData, formCtx) -> do
-        mResult <- insertUniqueEntity $ review _InvitableJunction (invitee, fid, jData)
+        let junction = review _InvitableJunction (invitee, fid, jData)
+        mResult <- invitationInsertHook fEnt iData junction formCtx $ insertUniqueEntity junction
         case mResult of
           Nothing -> invalidArgsI [MsgInvitationCollision]
           Just res -> do
             deleteBy . UniqueInvitation itEmail $ invRef @junction fid
-            addMessageI Success =<< invitationSuccessMsg fRec res
+            addMessageI Success =<< invitationSuccessMsg fEnt res
-            Just <$> invitationUltDest fRec res
+            Just <$> invitationUltDest fEnt res
 
   whenIsJust tRoute redirect
 

src/Handler/Utils/Table/Cells.hs

@@ -122,8 +122,7 @@ isNewCell = cell . toWidget . isNew
 -- | Maybe display comment icon linking a given URL or show nothing at all
 commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a
 commentCell Nothing     = mempty
-commentCell (Just link) = anchorCell link icon
+commentCell (Just link) = anchorCell link $ hasComment True
-  where icon = hasComment True
 
 -- | whether something is visible or hidden
 isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
@@ -134,11 +133,15 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
 
 -- | for simple file downloads
 fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-fileCell route = anchorCell route fileDownload
+fileCell route = anchorCell route iconFileDownload
 
 -- | for zip-archive downloads
 zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
-zipCell route = anchorCell route zipDownload
+zipCell route = anchorCell route iconFileZip
+
+-- | for csv downloads
+csvCell :: IsDBTable m a => Route UniWorX -> DBCell m a
+csvCell route = anchorCell route iconFileCSV
 
 -- | Display an icon that opens a modal upon clicking
 modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
@@ -197,11 +200,11 @@ cellHasEMail = emailCell . view _userEmail
 cellHasSemester :: (IsDBTable m c, HasStudyFeatures a) => a -> DBCell m c
 cellHasSemester = numCell . view _studyFeaturesSemester
 
-  
+
 cellHasField :: (IsDBTable m c, HasStudyTerms a) => a -> DBCell m c
 cellHasField x = maybe (numCell $ x ^. _studyTermsKey) textCell $ x ^. _studyTermsName <|> x ^. _studyTermsShorthand
 
-  
+
 cellHasDegreeShort :: (IsDBTable m c, HasStudyDegree a) => a -> DBCell m c
 cellHasDegreeShort x = maybe (numCell $ x ^. _studyDegreeKey) textCell $ x ^. _studyDegreeShorthand <|> x ^. _studyDegreeName
 

src/Handler/Utils/Table/Pagination.hs

@@ -306,7 +306,7 @@ instance Button UniWorX ButtonCsvMode where
   btnLabel BtnCsvExport
     = [whamlet|
         $newline never
-        #{iconCSV}
+        #{iconFileCSV}
         \ _{BtnCsvExport}
       |]
   btnLabel x = [whamlet|_{x}|]
@@ -940,8 +940,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                                  = handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException
                                  | otherwise            
                                  = id
-                            in yieldM . doHandle . runConduit $ dbtCsvComputeActions x .| C.fold accActionMap Map.empty
+                            in C.sourceList <=< lift . doHandle . runConduit $ dbtCsvComputeActions x .| C.foldMap pure
-                  innerAct .| C.foldMap id
+                  innerAct .| C.fold accActionMap Map.empty
               actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'
 
               when (Map.null actionMap) $ do

src/Handler/Utils/Tokens.hs

@@ -1,6 +1,6 @@
 module Handler.Utils.Tokens
   ( maybeBearerToken, requireBearerToken
-  , currentTokenRestrictions
+  , maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
   ) where
 
 import Import
@@ -27,8 +27,19 @@ requireBearerToken = liftHandlerT $ do
   guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
   return token
 
-currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
+maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
-currentTokenRestrictions = runMaybeT $ do
+                                                                  , HandlerSite m ~ UniWorX
+                                                                  , MonadCatch m
+                                                                  , MonadLogger m
+                                                                  , FromJSON a
+                                                                  , ToJSON a
+                                                                  )
+                                                               => m (Maybe a)
+requireCurrentTokenRestrictions = runMaybeT $ do
   token <- requireBearerToken
   route <- MaybeT getCurrentRoute
-  hoistMaybe $ preview (_tokenRestrictionIx route) token
+  hoistMaybe $ token ^? _tokenRestrictionIx route
+maybeCurrentTokenRestrictions = runMaybeT $ do
+  token <- MaybeT maybeBearerToken
+  route <- MaybeT getCurrentRoute
+  hoistMaybe $ token ^? _tokenRestrictionIx route

src/Handler/Utils/Users.hs

@@ -0,0 +1,17 @@
+module Handler.Utils.Users
+  ( computeUserAuthenticationDigest
+  , Digest, SHA3_256
+  , constEq
+  ) where
+
+import Import
+
+import Crypto.Hash (Digest, SHA3_256, hashlazy)
+
+import Data.ByteArray (constEq)
+
+import qualified Data.Aeson as JSON
+
+
+computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
+computeUserAuthenticationDigest = hashlazy . JSON.encode

src/Import/NoModel.hs

@@ -3,7 +3,7 @@ module Import.NoModel
   , MForm
   ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
 
 import Model.Types.TH.JSON as Import
 import Model.Types.TH.Wordlist as Import
@@ -27,6 +27,7 @@ import Data.UUID              as Import (UUID)
 import Data.CaseInsensitive   as Import (CI, FoldCase(..), foldedCase)
 
 import Text.Lucius            as Import
+import Text.Julius            as Import
 import Text.Shakespeare.Text  as Import hiding (text, stext)
 
 import Data.Universe          as Import
@@ -43,8 +44,8 @@ import Data.Ix                as Import (Ix)
 import Data.Hashable          as Import
 import Data.List.NonEmpty     as Import (NonEmpty(..), nonEmpty)
 import Data.Text.Encoding.Error as Import(UnicodeException(..))
-import Data.Semigroup         as Import (Semigroup)
+import Data.Semigroup         as Import (Semigroup, Min(..), Max(..))
-import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..))
+import Data.Monoid            as Import (Last(..), First(..), Any(..), All(..), Sum(..), Endo(..))
 import Data.Binary            as Import (Binary)
 
 import Numeric.Natural        as Import (Natural)
@@ -53,7 +54,7 @@ import Data.Ratio             as Import ((%))
 import Net.IP                 as Import (IP)
 
 import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
-  
+
 import Ldap.Client.Pool as Import
 
 import System.Random as Import (Random(..))
@@ -70,7 +71,7 @@ import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
 import Time.Types as Import (WeekDay(..))
 
 import Network.Mime as Import
-  
+
 import Data.Aeson.TH as Import
 import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
 
@@ -87,6 +88,7 @@ import Data.Maybe.Instances  as Import ()
 import Data.CryptoID.Instances  as Import ()
 import Data.Sum.Instances     as Import ()
 import Data.Fixed.Instances   as Import ()
+import Data.Scientific.Instances   as Import ()
 import Data.Set.Instances     as Import ()
 import Data.HashMap.Strict.Instances as Import ()
 import Data.HashSet.Instances as Import ()

src/Jobs.hs

@@ -7,19 +7,17 @@ module Jobs
 
 import Import
 import Utils.Lens
-import Handler.Utils
 
 import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
 import Jobs.Types (JobCtl(JobCtlQueue))
 import Jobs.Queue
 import Jobs.Crontab
 
-import Data.Conduit.TMChan
 import qualified Data.Conduit.List as C
 
 import qualified Data.Text.Lazy as LT
 
-import Data.Aeson (fromJSON, toJSON)
+import Data.Aeson (fromJSON)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 import Database.Persist.Sql (fromSqlKey)
@@ -28,7 +26,7 @@ import Data.Semigroup (Max(..))
 
 import Utils.Sql
 
-import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
+import Control.Monad.Random (evalRand, mkStdGen, getRandomR, uniformMay)
 
 import Cron
 import qualified Data.HashMap.Strict as HashMap
@@ -38,20 +36,26 @@ import qualified Data.Set as Set
 import qualified Data.List.NonEmpty as NonEmpty
 
 import qualified Data.Map.Strict as Map
+import Data.Map.Strict ((!))
 
 import Data.Foldable (foldrM)
 
 import Control.Monad.Trans.Reader (mapReaderT)
-import Control.Monad.Trans.State (evalStateT, mapStateT)
+import Control.Monad.Trans.Writer (execWriterT)
+import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
 import qualified Control.Monad.State.Class as State
+import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate, release)
+import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Cont (ContT(..), callCC)
+import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
 import Control.Monad.Logger
 
 import Data.Time.Zones
 
 import Control.Concurrent.STM (retry)
+import Control.Concurrent.STM.Delay
 
 
 import Jobs.Handler.SendNotification
@@ -62,6 +66,8 @@ import Jobs.Handler.SetLogSettings
 import Jobs.Handler.DistributeCorrections
 import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.Invitation
+import Jobs.Handler.SendPasswordReset
+import Jobs.Handler.TransactionLog
 
 import Jobs.HealthReport
 
@@ -75,198 +81,268 @@ instance Exception JobQueueException
 
 
 handleJobs :: ( MonadResource m
-              , MonadIO m
+              , MonadLoggerIO m
               )
            => UniWorX -> m ()
 -- | Spawn a set of workers that read control commands from `appJobCtl` and address them as they come in
 --
 -- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
 -- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
-handleJobs foundation@UniWorX{..} = do
+handleJobs foundation@UniWorX{..}
-  let num = foundation ^. _appJobWorkers
+  | foundation ^. _appJobWorkers == 0 = return ()
+  | otherwise = do
+      logger <- askLoggerIO
+      let runInIO = flip runLoggingT logger . runResourceT
 
-  jobCrontab <- liftIO $ newTMVarIO HashMap.empty
+      jobPoolManager <- allocateLinkedAsync . runInIO $ manageJobPool foundation
-  jobConfirm <- liftIO $ newTVarIO HashMap.empty
 
-  forM_ [1..num] $ \n -> do
+      jobCron <- allocateLinkedAsync . runInIO $ manageCrontab foundation
-    (bChan, chan) <- atomically $ newBroadcastTMChan >>= (\c -> (c, ) <$> dupTMChan c)
-    let
-      logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
-      logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
-      removeChan = atomically . modifyTVar' appJobCtl . Map.delete =<< myThreadId
-      doFork = flip forkFinally (\_ -> removeChan) . runAppLoggingT foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' foundation n
-    (_, tId) <- allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
-    atomically . modifyTVar' appJobCtl $ Map.insert tId bChan
 
-  -- Start cron operation
+      let jobWorkers = Map.empty
-  when (num > 0) $ do
+          jobWorkerName = const $ error "Unknown worker"
-    registeredCron <- liftIO newEmptyTMVarIO
+      jobCrontab <- liftIO $ newTVarIO HashMap.empty
-    let execCrontab' = whenM (atomically $ readTMVar registeredCron) $
+      jobConfirm <- liftIO $ newTVarIO HashMap.empty
-          runReaderT (execCrontab foundation) JobContext{..}
+      jobShutdown <- liftIO newEmptyTMVarIO
-        unregister = atomically . whenM (fromMaybe False <$> tryReadTMVar registeredCron) . void $ tryTakeTMVar appCronThread
+      atomically $ putTMVar appJobState JobState
-    cData <- allocate (liftIO . forkFinally execCrontab' $ \_ -> unregister) (\_ -> liftIO . atomically . void $ tryTakeTMVar jobCrontab)
+        { jobContext = JobContext{..}
-    registeredCron' <- atomically $ do
+        , ..
-      registeredCron' <- tryPutTMVar appCronThread cData
+        }
-      registeredCron' <$ putTMVar registeredCron registeredCron'
-    when registeredCron' $
-      liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
-        writeJobCtlBlock JobCtlDetermineCrontab
 
-stopJobCtl :: MonadIO m => UniWorX -> m ()
+manageJobPool, manageCrontab :: forall m.
+                                ( MonadResource m
+                                , MonadLogger m
+                                )
+                             => UniWorX -> m ()
+manageCrontab foundation@UniWorX{..} = do
+  context <- atomically . fmap jobContext $ readTMVar appJobState
+  let awaitTermination = atomically $ do
+        shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
+        guard shouldTerminate
+  liftIO . race_ awaitTermination . unsafeHandler foundation . void $ do
+    atomically . assertM_ (not . Map.null . jobWorkers) $ readTMVar appJobState
+    runReaderT ?? foundation $
+      writeJobCtlBlock JobCtlDetermineCrontab
+    evalRWST (forever execCrontab) context HashMap.empty
+
+
+manageJobPool foundation@UniWorX{..}
+  = flip runContT return . forever . join . atomically $ asum
+      [ spawnMissingWorkers
+      , reapDeadWorkers
+      , terminateGracefully
+      ]
+  where
+    num :: Int
+    num = fromIntegral $ foundation ^. _appJobWorkers
+
+    spawnMissingWorkers, reapDeadWorkers, terminateGracefully :: STM (ContT () m ())
+    spawnMissingWorkers = do
+      oldState <- takeTMVar appJobState
+      let missing = num - Map.size (jobWorkers oldState)
+      guard $ missing > 0
+      return $ do
+        $logDebugS "manageJobPool" [st|Spawning #{missing} workers|]
+        endo <- execWriterT . replicateM_ missing $ do
+          workerId <- newWorkerId
+          let logIdent = mkLogIdent workerId
+          (bChan, chan) <- atomically $ newBroadcastTChan >>= (\c -> (c, ) <$> dupTChan c)
+          let
+            streamChan = join . atomically $ do
+              shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
+              if
+                | shouldTerminate ->
+                    return $ return ()
+                | otherwise -> do
+                    nextVal <- readTChan chan
+                    return $ yield nextVal >> streamChan
+            runWorker = unsafeHandler foundation . flip runReaderT (jobContext oldState) $ do
+              $logInfoS logIdent "Started"
+              runConduit $ streamChan .| handleJobs' workerId
+              $logInfoS logIdent "Stopped"
+          worker <- allocateLinkedAsync runWorker
+
+          tell . Endo $ \cSt -> cSt
+            { jobWorkers = Map.insert worker bChan $ jobWorkers cSt
+            , jobWorkerName = \a -> bool (jobWorkerName cSt a) workerId $ a == worker
+            }
+        atomically . putTMVar appJobState $ endo `appEndo` oldState
+
+    reapDeadWorkers = do
+      oldState <- takeTMVar appJobState
+      deadWorkers <- fmap (Map.fromList . catMaybes) . forM (Map.keys $ jobWorkers oldState) $ \a -> fmap (a,) <$> pollSTM a
+      putTMVar appJobState oldState
+        { jobWorkers = jobWorkers oldState `Map.withoutKeys` Map.keysSet deadWorkers
+        }
+      guard . not $ Map.null deadWorkers
+      return . forM_ (Map.toList deadWorkers) $ \(jobAsync, result) -> do
+        case result of
+          Right () -> $logInfoS "JobPoolManager" [st|Job-Executor #{showWorkerId (jobWorkerName oldState jobAsync)} terminated|]
+          Left e   -> $logErrorS "JobPoolManager" [st|Job-Executer #{showWorkerId (jobWorkerName oldState jobAsync)} crashed: #{tshow e}|]
+        void . lift . allocateLinkedAsync $
+          let go = do
+                next <- evalRandTIO . mapRandT (liftIO . atomically) . runMaybeT $ do
+                  nextVal <- MaybeT . lift . tryReadTChan $ jobWorkers oldState ! jobAsync
+                  jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
+                  receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers'
+                  return (nextVal, receiver)
+                whenIsJust next $ \(nextVal, receiver) -> do
+                  atomically $ writeTChan receiver nextVal
+                  go
+           in go
+        
+    terminateGracefully = do
+      shouldTerminate <- readTMVar appJobState >>= fmap not . isEmptyTMVar . jobShutdown
+      guard shouldTerminate
+      return . callCC $ \terminate -> do
+        $logInfoS "JobPoolManager" "Shutting down"
+        terminate ()
+
+stopJobCtl :: (MonadIO m, MonadBaseControl IO m) => UniWorX -> m ()
 -- ^ Stop all worker threads currently running
-stopJobCtl UniWorX{appJobCtl, appCronThread} = do
+stopJobCtl UniWorX{appJobState} = do
-  mcData <- atomically $ tryReadTMVar appCronThread
+  didStop <- atomically $ do
-  whenIsJust mcData $ \(rKey, _) -> do
+    jState <- tryReadTMVar appJobState
-    liftIO $ release rKey
+    for jState $ \jSt'@JobState{jobShutdown} -> jSt' <$ tryPutTMVar jobShutdown ()
-    atomically . guardM $ isEmptyTMVar appCronThread
+  whenIsJust didStop $ \jSt' -> void . fork . atomically $ do
-  
+    workers <- maybe [] (Map.keys . jobWorkers) <$> tryTakeTMVar appJobState
-  wMap <- liftIO $ readTVarIO appJobCtl
+    mapM_ (void . waitCatchSTM) $
-  atomically $ forM_ wMap closeTMChan
+      [ jobPoolManager jSt'
-  atomically $ do
+      , jobCron jSt'
-    wMap' <- readTVar appJobCtl
+      ] ++ workers
-    guard . none (`Map.member` wMap') $ Map.keysSet wMap
 
-
+execCrontab :: RWST JobContext () (HashMap JobCtl (Max UTCTime)) (HandlerT UniWorX IO) ()
-execCrontab :: MonadIO m => UniWorX -> ReaderT JobContext m ()
 -- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
 --   seen, wait for the time of the next job and fire it
-execCrontab foundation = evalStateT go HashMap.empty
+execCrontab = do
-  where
+  mapRWST (liftHandlerT . runDB . setSerializable) $ do
-    go = do
+    let
-      cont <- mapStateT (mapReaderT $ liftIO . unsafeHandler foundation) $ do
+      mergeLastExec (Entity leId CronLastExec{..})
-        mapStateT (liftHandlerT . runDB . setSerializable) $ do
+        | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
-          let
+        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
-            merge (Entity leId CronLastExec{..})
+        | otherwise = lift $ delete leId
-              | Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
-              = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
-              | otherwise = lift $ delete leId
-          runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
 
-        refT <- liftIO getCurrentTime
+      mergeQueued (Entity qjId QueuedJob{..})
-        settings <- getsYesod appSettings'
+        | Just job <- Aeson.parseMaybe parseJSON queuedJobContent
-        currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
+        = State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max queuedJobCreationTime)
-          crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
+        | otherwise = lift $ delete qjId
-          case crontab' of
+    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeLastExec
-            Nothing -> return Nothing
+    runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ mergeQueued
-            Just crontab -> Just <$> do
-              State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
-              prevExec <- State.get
-              case earliestJob settings prevExec crontab refT of
-                Nothing -> liftBase retry
-                Just (_, MatchNone) -> liftBase retry
-                Just x -> return (crontab, x)
 
-        case currentState of
+  refT <- liftIO getCurrentTime
-          Nothing -> return False
+  settings <- getsYesod appSettings'
-          Just (currentCrontab, (jobCtl, nextMatch)) -> do
+  (currentCrontab, (jobCtl, nextMatch)) <- mapRWST (liftIO . atomically) $ do
-            let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
+    crontab <- liftBase . readTVar =<< asks jobCrontab
-                    newCrontab <- lift . lift . hoist lift $ determineCrontab'
-                    if
-                      | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-                        -> do
-                          now <- liftIO $ getCurrentTime
-                          instanceID' <- getsYesod appInstanceID
-                          State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
-                          case jobCtl of
-                            JobCtlQueue job -> do
-                              void . lift . lift $ upsertBy
-                                (UniqueCronLastExec $ toJSON job)
-                                CronLastExec
-                                  { cronLastExecJob = toJSON job
-                                  , cronLastExecTime = now
-                                  , cronLastExecInstance = instanceID'
-                                  }
-                                [ CronLastExecTime =. now ]
-                              lift . lift $ queueDBJob job
-                            other -> writeJobCtl other
-                      | otherwise
-                        -> lift . mapReaderT (liftIO . atomically) $
-                             lift . void . flip swapTMVar newCrontab =<< asks jobCrontab
 
-            case nextMatch of
+    State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
-              MatchAsap -> doJob
+    prevExec <- State.get
-              MatchNone -> return ()
+    case earliestJob settings prevExec crontab refT of
-              MatchAt nextTime -> do
+      Nothing -> liftBase retry
-                JobContext{jobCrontab} <- ask
+      Just (_, MatchNone) -> liftBase retry
-                nextTime' <- applyJitter jobCtl nextTime
+      Just x -> return (crontab, x)
-                $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
-                logFunc <- askLoggerIO
-                whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
-                  doJob
 
-            return True
+  -- do
-      when cont go
+  --   lastTimes <- State.get
-      where
+  --   now <- liftIO getCurrentTime
-        acc :: NominalDiffTime
+  --   $logDebugS "Crontab" . intercalate "\n" . map tshow . sortOn fst . flip map (HashMap.toList currentCrontab) $ \(job, cron) -> (,job) $ nextCronMatch appTZ (getMax <$> HashMap.lookup job lastTimes) (debouncingAcc settings job) now cron
-        acc = 1e-3
 
-        debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
+  let doJob = mapRWST (liftHandlerT . runDBJobs . setSerializable) $ do
-        debouncingAcc AppSettings{appNotificationRateLimit} = \case
+          newCrontab <- lift . hoist lift $ determineCrontab'
-          JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
-          _ -> acc
-
-        applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
-        applyJitter seed t = do
-          appInstance <- getsYesod appInstanceID
-          let
-            halfRange = truncate $ 0.5 / acc
-            diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
-          return $ addUTCTime diff t
-
-        earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
-        earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
-          where
-            go' (jobCtl, cron) mbPrev
-              | Just (_, t') <- mbPrev
-              , t' < t
-              = mbPrev
-              | otherwise
-              = Just (jobCtl, t)
-              where
-                t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
-
-        waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TMVar a -> a -> UTCTime -> m Bool
-        waitUntil crontabTV crontab nextTime = runResourceT $ do
-          diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
-          let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
-              waitTime'
-                | diffT < acc = "Done"
-                | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
-          $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
           if
-            | diffT < acc -> return True
+            | ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-            | otherwise   -> do
+              -> do
-                retVar <- liftIO newEmptyTMVarIO
+                now <- liftIO $ getCurrentTime
-                void . liftIO . forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar
+                foundation <- getYesod
-                let
+                State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
-                  awaitDelayThread = False <$ takeTMVar retVar
+                case jobCtl of
-                  awaitCrontabChange = do
+                  JobCtlQueue job -> lift $ queueDBJobCron job
-                    crontab' <- tryReadTMVar crontabTV
+                  other -> runReaderT ?? foundation $ writeJobCtl other
-                    True <$ guard (Just crontab /= crontab')
+            | otherwise
-                crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+              -> mapRWST (liftIO . atomically) $
-                bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+                   liftBase . void . flip swapTVar newCrontab =<< asks jobCrontab
 
+  case nextMatch of
+    MatchAsap -> doJob
+    MatchNone -> return ()
+    MatchAt nextTime -> do
+      JobContext{jobCrontab} <- ask
+      nextTime' <- applyJitter jobCtl nextTime
+      $logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
+      logFunc <- askLoggerIO
+      whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
+        doJob
+  where
+    acc :: NominalDiffTime
+    acc = 1e-3
 
-handleJobs' :: (MonadIO m, MonadLogger m, MonadCatch m) => UniWorX -> Natural -> Sink JobCtl (ReaderT JobContext m) ()
+    debouncingAcc :: AppSettings -> JobCtl -> NominalDiffTime
-handleJobs' foundation wNum = C.mapM_ $ \jctl -> do
+    debouncingAcc AppSettings{appNotificationRateLimit} = \case
+      JobCtlQueue (JobQueueNotification _) -> appNotificationRateLimit
+      _ -> acc
+
+    applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
+    applyJitter seed t = do
+      appInstance <- getsYesod appInstanceID
+      let
+        halfRange = truncate $ 0.5 / acc
+        diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
+      return $ addUTCTime diff t
+
+    earliestJob :: AppSettings -> HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
+    earliestJob settings lastTimes crontab now = foldr go' Nothing $ HashMap.toList crontab
+      where
+        go' (jobCtl, cron) mbPrev
+          | Just (_, t') <- mbPrev
+          , t' < t
+          = mbPrev
+          | otherwise
+          = Just (jobCtl, t)
+          where
+            t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) (debouncingAcc settings jobCtl) now cron
+
+    waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
+    waitUntil crontabTV crontab nextTime = runResourceT $ do
+      diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
+      let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
+          waitTime'
+            | diffT < acc = "Done"
+            | otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
+      $logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
+      if
+        | diffT < acc -> return True
+        | otherwise   -> do
+            delay <- liftIO . newDelay . round $ waitTime * 1e6
+            let
+              awaitDelayThread = False <$ waitDelay delay
+              awaitCrontabChange = do
+                crontab' <- readTVar crontabTV
+                True <$ guard (crontab /= crontab')
+            crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
+            bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
+
+mkLogIdent :: JobWorkerId -> Text
+mkLogIdent wId = "Job-Executor " <> showWorkerId wId
+
+handleJobs' :: JobWorkerId -> Sink JobCtl (ReaderT JobContext Handler) ()
+handleJobs' wNum = C.mapM_ $ \jctl -> do
   $logDebugS logIdent $ tshow jctl
-  resVars <- mapReaderT (liftIO . atomically) $
+  res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
-    HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
+  sentRes <- mapReaderT (liftIO . atomically) $ do
-  res <- fmap (either Just $ const Nothing) . try . (mapReaderT $ liftIO . unsafeHandler foundation) $ handleCmd jctl
+    resVars <- HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
-  sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
+    lift $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
   case res of
     Just err
       | not sentRes -> $logErrorS logIdent $ tshow err
     _other -> return ()
   where
-    logIdent = "Jobs #" <> tshow wNum
+    logIdent = mkLogIdent wNum
     
     handleQueueException :: MonadLogger m => JobQueueException -> m ()
     handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
     handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
     handleQueueException (JLocked jId lInstance lTime)  = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
 
-    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
+    handleCmd JobCtlNoOp = return ()
+    handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (lift . writeJobCtl . JobCtlPerform)
     handleCmd (JobCtlQueue job) = lift $ queueJob' job
     handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
       content <- case fromJSON queuedJobContent of
@@ -277,15 +353,30 @@ handleJobs' foundation wNum = C.mapM_ $ \jctl -> do
       
       $logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
 
+      instanceID' <- getsYesod $ view instanceID
+      now <- liftIO getCurrentTime
+  
       performJob content
 
       -- `performJob` is expected to throw an exception if it detects that the job was not done
-      runDB $ delete jId
+      runDB . setSerializable $ do
+        when queuedJobWriteLastExec $
+          void $ upsertBy
+            (UniqueCronLastExec queuedJobContent)
+            CronLastExec
+              { cronLastExecJob = queuedJobContent
+              , cronLastExecTime = now
+              , cronLastExecInstance = instanceID'
+              }
+            [ CronLastExecTime =. now
+            , CronLastExecInstance =. instanceID'
+            ]
+        delete jId
     handleCmd JobCtlDetermineCrontab = do
       newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
       -- logDebugS logIdent $ tshow newCTab
       mapReaderT (liftIO . atomically) $ 
-        lift . void . flip swapTMVar newCTab =<< asks jobCrontab
+        lift . void . flip swapTVar newCTab =<< asks jobCrontab
     handleCmd (JobCtlGenerateHealthReport kind) = do
       hrStorage <- getsYesod appHealthReport
       newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind

src/Jobs/Crontab.hs

@@ -4,6 +4,8 @@ module Jobs.Crontab
 
 import Import 
 
+import Utils.Lens
+
 import qualified Data.HashMap.Strict as HashMap
 import Jobs.Types
 
@@ -17,6 +19,8 @@ import Control.Monad.Writer.Class (MonadWriter(..))
 
 import qualified Data.Conduit.List as C
 
+import qualified Database.Esqueleto as E
+
 
 determineCrontab :: DB (Crontab JobCtl)
 -- ^ Extract all future jobs from the database (sheet deadlines, ...)
@@ -55,6 +59,33 @@ determineCrontab = execWriterT $ do
           }
       Nothing  -> mempty
 
+  let newyear = cronCalendarAny
+        { cronDayOfYear  = cronMatchOne 1
+        }
+   in tell $ HashMap.singleton
+        (JobCtlQueue JobTruncateTransactionLog)
+        Cron
+          { cronInitial = newyear
+          , cronRepeat = CronRepeatScheduled newyear
+          , cronRateLimit = minNominalYear
+          , cronNotAfter = Right CronNotScheduled
+          }
+
+  oldestLogEntry <- fmap listToMaybe . lift . E.select . E.from $ \transactionLog -> do
+    E.where_ . E.not_ . E.isNothing $ transactionLog E.^. TransactionLogRemote
+    E.orderBy [E.asc $ transactionLog E.^. TransactionLogTime]
+    E.limit 1
+    return $ transactionLog E.^. TransactionLogTime
+  for_ oldestLogEntry $ \(E.Value oldestEntry) ->
+    tell $ HashMap.singleton
+      (JobCtlQueue JobDeleteTransactionLogIPs)
+      Cron
+        { cronInitial   = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appTransactionLogIPRetentionTime oldestEntry
+        , cronRepeat    = CronRepeatOnChange
+        , cronRateLimit = nominalDay
+        , cronNotAfter  = Right CronNotScheduled
+        }
+
   let
     sheetJobs (Entity nSheet Sheet{..}) = do
       tell $ HashMap.singleton
@@ -118,3 +149,24 @@ determineCrontab = execWriterT $ do
        transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] []
                       )
     .| C.fold collateSubmissionsByCorrector Map.empty
+
+  
+  let
+    examJobs (Entity nExam Exam{..}) = do
+      newestResult <- lift . E.select . E.from $ \examResult -> do
+        E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
+        return . E.max_ $ examResult E.^. ExamResultLastChanged
+
+      case over (mapped . _Value) ((max `on` NTop) examFinished) newestResult of
+        [E.Value (NTop (Just ts))] -> 
+          tell $ HashMap.singleton
+            (JobCtlQueue $ JobQueueNotification NotificationExamResult{..})
+            Cron
+              { cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ ts
+              , cronRepeat = CronRepeatOnChange
+              , cronRateLimit = appNotificationRateLimit
+              , cronNotAfter = Left $ 14 * nominalDay
+              }
+        _other -> return ()
+  
+  runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ examJobs

src/Jobs/Handler/QueueNotification.hs

@@ -55,19 +55,28 @@ determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet}
       E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
       E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
       return user
-determineNotificationCandidates NotificationUserRightsUpdate{..}
+determineNotificationCandidates NotificationUserRightsUpdate{..} = do
-  = do
+  -- always send to affected user
-      -- always send to affected user
+  affectedUser <- selectList [UserId ==. nUser] []
-      affectedUser <- selectList [UserId ==. nUser] []
+  -- send to same-school admins only if there was an update
-      -- send to same-school admins only if there was an update
+  currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] []
-      currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] []
+  let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ]
-      let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- originalRights ]
+      newAdminSchools = currentAdminSchools \\ oldAdminSchools
-          newAdminSchools = currentAdminSchools \\ oldAdminSchools
+  affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
-      affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
+    E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId
-        E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId
+    E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools
-        E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools
+    return user
-        return user
+  return $ nub $ affectedUser <> affectedAdmins
-      return $ nub $ affectedUser <> affectedAdmins
+determineNotificationCandidates NotificationUserAuthModeUpdate{..}
+  = selectList [UserId ==. nUser] []
+determineNotificationCandidates notif@NotificationExamResult{..} = do
+  lastExec <- fmap (fmap $ cronLastExecTime . entityVal) . getBy . UniqueCronLastExec . toJSON $ JobQueueNotification notif
+  E.select . E.from $ \(examResult `E.InnerJoin` user) -> do
+    E.on $ examResult E.^. ExamResultUser E.==. user E.^. UserId
+    E.where_ $ examResult E.^. ExamResultExam E.==. E.val nExam
+    whenIsJust lastExec $ \lastExec' ->
+      E.where_ $ examResult E.^. ExamResultLastChanged E.>. E.val lastExec'
+    return user
 
 
 classifyNotification :: Notification -> DB NotificationTrigger
@@ -82,5 +91,5 @@ classifyNotification NotificationSheetInactive{} = return NTSheetInactive
 classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
 classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
 classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate
-
+classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate
-
+classifyNotification NotificationExamResult{} = return NTExamResult

src/Jobs/Handler/SendNotification.hs

@@ -13,6 +13,8 @@ import Jobs.Handler.SendNotification.SheetInactive
 import Jobs.Handler.SendNotification.CorrectionsAssigned
 import Jobs.Handler.SendNotification.CorrectionsNotDistributed
 import Jobs.Handler.SendNotification.UserRightsUpdate
+import Jobs.Handler.SendNotification.UserAuthModeUpdate
+import Jobs.Handler.SendNotification.ExamResult
 
 
 dispatchJobSendNotification :: UserId -> Notification -> Handler ()

src/Jobs/Handler/SendNotification/ExamResult.hs

@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.ExamResult
+  ( dispatchNotificationExamResult
+  ) where
+
+import Import
+
+import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
+
+import Text.Hamlet
+import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationExamResult :: ExamId -> UserId -> Handler ()
+dispatchNotificationExamResult nExam jRecipient = userMailT jRecipient $ do
+  (Course{..}, Exam{..}) <- liftHandlerT . runDB $ do
+    exam <- getJust nExam
+    course <- belongsToJust examCourse exam
+    return (course, exam)
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  setSubjectI $ MsgMailSubjectExamResult courseShorthand examName
+
+  MsgRenderer mr <- getMailMsgRenderer
+  let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
+      tid = courseTerm
+      ssh = courseSchool
+      csh = courseShorthand
+      examn = examName
+
+  editNotifications <- mkEditNotifications jRecipient
+
+  addAlternatives $
+    providePreferredAlternative ($(ihamletFile "templates/mail/examResult.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs

@@ -0,0 +1,26 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
+
+module Jobs.Handler.SendNotification.UserAuthModeUpdate
+  ( dispatchNotificationUserAuthModeUpdate
+  ) where
+
+import Import
+import Utils.Lens
+
+import Handler.Utils.Mail
+import Jobs.Handler.SendNotification.Utils
+
+import Text.Hamlet
+-- import qualified Data.CaseInsensitive as CI
+
+dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler ()
+dispatchNotificationUserAuthModeUpdate  nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do
+    User{..} <- liftHandlerT . runDB $ getJust nUser
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+    setSubjectI MsgMailSubjectUserAuthModeUpdate
+
+    editNotifications <- mkEditNotifications jRecipient
+
+    addAlternatives $
+      providePreferredAlternative ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
+

src/Jobs/Handler/SendPasswordReset.hs

@@ -0,0 +1,41 @@
+module Jobs.Handler.SendPasswordReset
+  ( dispatchJobSendPasswordReset
+  ) where
+
+import Import
+
+import Utils.Lens
+import Handler.Utils
+import Handler.Utils.Users
+
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteArray as BA
+import qualified Data.HashSet as HashSet
+
+import Text.Hamlet
+
+dispatchJobSendPasswordReset :: UserId
+                             -> Handler ()
+dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
+  cID <- encrypt jRecipient
+  User{..} <- liftHandlerT . runDB $ getJust jRecipient
+  
+  replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
+  setSubjectI MsgMailSubjectPasswordReset
+
+  now <- liftIO getCurrentTime
+  let
+    localNow = utcToLocalTime now
+    tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
+      LTUUnique utc' _ -> utc'
+      _other           -> UTCTime (addDays 2 $ utctDay now) 0
+
+  resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
+  let resetToken = resetToken'
+        & tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
+  encodedToken <- encodeToken resetToken
+
+  resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)])
+
+  addAlternatives $
+    providePreferredAlternative ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

src/Jobs/Handler/TransactionLog.hs

@@ -0,0 +1,32 @@
+module Jobs.Handler.TransactionLog
+  ( dispatchJobTruncateTransactionLog
+  , dispatchJobDeleteTransactionLogIPs
+  ) where
+
+import Import hiding (currentYear)
+import Utils.Lens hiding ((<.))
+import Handler.Utils.DateTime
+
+import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
+
+dispatchJobTruncateTransactionLog, dispatchJobDeleteTransactionLogIPs :: Handler ()
+dispatchJobTruncateTransactionLog = do
+  now <- liftIO getCurrentTime
+  let localNow = utcToLocalTime now
+      (localCurrentYear, _, _) = toGregorian $ localDay localNow
+      localStartOfPreviousYear = LocalTime (fromGregorian (pred localCurrentYear) 1 1) midnight
+      (currentYear, _, _) = toGregorian $ utctDay now
+      startOfPreviousYear = UTCTime (fromGregorian (pred currentYear) 1 1) 0
+      startOfPreviousYear' = case localTimeToUTC localStartOfPreviousYear of
+        LTUUnique utc' _ -> utc'
+        _other           -> startOfPreviousYear
+
+  n <- runDB $ deleteWhereCount [ TransactionLogTime <. startOfPreviousYear' ]
+  $logInfoS "TruncateTransactionLog" [st|Deleted #{n} transaction log entries|]
+dispatchJobDeleteTransactionLogIPs = do
+  now <- liftIO getCurrentTime
+  retentionTime <- getsYesod $ view _appTransactionLogIPRetentionTime
+  let cutoff = addUTCTime (- retentionTime) now
+
+  n <- runDB $ updateWhereCount [ TransactionLogTime <. cutoff ] [ TransactionLogRemote =. Nothing ]
+  $logInfoS "DeleteTransactionLogIPs" [st|Deleted #{n} IP entries from transaction log|]

src/Jobs/HealthReport.hs

@@ -7,6 +7,7 @@ module Jobs.HealthReport
 import Import
 
 import Data.List (genericLength)
+import qualified Data.Map.Strict as Map
 
 import qualified Data.Aeson as Aeson
 import Data.Proxy (Proxy(..))
@@ -27,6 +28,12 @@ import qualified Data.CaseInsensitive as CI
 import qualified Network.HaskellNet.SMTP as SMTP
 import Data.Pool (withResource)
 
+import System.Timeout
+
+import Jobs.Queue
+
+import Control.Concurrent.Async.Lifted.Safe (forConcurrently)
+
 
 generateHealthReport :: HealthCheck -> Handler HealthReport
 generateHealthReport = $(dispatchTH ''HealthCheck)
@@ -135,3 +142,26 @@ dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
         (== content) . responseBody <$> httpLBS httpRequest
       _other -> return False
       
+
+dispatchHealthCheckActiveJobExecutors :: Handler HealthReport
+dispatchHealthCheckActiveJobExecutors = HealthActiveJobExecutors <$> do
+  app <- getYesod
+  jState <- atomically . tryReadTMVar $ appJobState app
+  let configuredNumber = app ^. _appJobWorkers
+      timeoutLength = app ^. _appHealthCheckActiveJobExecutorsTimeout
+  case jState of
+    Nothing
+      | configuredNumber == 0 -> return Nothing
+    Nothing -> return $ Just 0
+    Just JobState{jobWorkers, jobWorkerName} -> do
+      tid <- liftIO myThreadId
+      let workers' = Map.fromSet jobWorkerName (Map.keysSet jobWorkers)
+          workers = Map.filterWithKey (\a _ -> asyncThreadId a /= tid) workers'
+          timeoutMicro = let (MkFixed micro :: Micro) = realToFrac timeoutLength
+                          in fromInteger micro
+      $logDebugS "HealthCheckActiveJobExecutors" . tshow . map showWorkerId $ Map.elems workers'
+      responders <- fmap (getSum . fold) . liftIO . forConcurrently (Map.toList workers) $ \(_, wName)
+        -> fromMaybe (Sum 0) <$> timeout timeoutMicro (runReaderT ?? app $ Sum 1 <$ writeJobCtlBlock' (writeJobCtl' wName) JobCtlNoOp)
+      if
+        | Map.null workers -> return Nothing
+        | otherwise        -> return . Just $ responders % fromIntegral (Map.size workers)

src/Jobs/Queue.hs

@@ -1,20 +1,24 @@
 module Jobs.Queue
   ( writeJobCtl, writeJobCtlBlock
+  , writeJobCtl', writeJobCtlBlock'
   , queueJob, queueJob'
   , YesodJobDB
   , runDBJobs, queueDBJob, sinkDBJobs
+  , queueDBJobCron
   , module Jobs.Types
   ) where
 
 import Import hiding ((<>))
 
 import Utils.Sql
+import Utils.Lens
 import Jobs.Types
 
 import Control.Monad.Trans.Writer (WriterT, runWriterT)
 import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
 
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.HashMap.Strict as HashMap
@@ -27,49 +31,63 @@ import Data.Semigroup ((<>))
 
 
 data JobQueueException = JobQueuePoolEmpty
+                       | JobQueueWorkerNotFound
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
 
 instance Exception JobQueueException
 
 
-writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
+writeJobCtl' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobWorkerId -> JobCtl -> m ()
+-- | Pass an instruction to the given `Job`-Worker
+writeJobCtl' target cmd = do
+  JobState{jobWorkers, jobWorkerName} <- asks appJobState >>= atomically . readTMVar
+  if
+    | null jobWorkers
+      -> throwM JobQueuePoolEmpty
+    | [(_, chan)] <- filter ((== target) . jobWorkerName . view _1) $ Map.toList jobWorkers
+      -> atomically $ writeTChan chan cmd
+    | otherwise
+      -> throwM JobQueueWorkerNotFound
+
+writeJobCtl :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m ()
 -- | Pass an instruction to the `Job`-Workers
 --
 -- Instructions are assigned deterministically and pseudo-randomly to one specific worker.
 -- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others
 writeJobCtl cmd = do
+  names <- fmap jobWorkerNames $ asks appJobState >>= atomically . readTMVar
   tid <- liftIO myThreadId
-  wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
+  let target = evalRand ?? mkStdGen (hash tid `hashWithSalt` cmd) $ uniform names
-  if
+  writeJobCtl' target cmd
-    | null wMap -> throwM JobQueuePoolEmpty
-    | otherwise -> do
-        let chan = flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) $ uniform wMap
-        liftIO . atomically $ writeTMChan chan cmd
 
-writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
+
--- | Pass an instruction to the `Job`-Workers and block until it was acted upon
+writeJobCtlBlock' :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => (JobCtl -> m ()) -> JobCtl -> m ()
-writeJobCtlBlock cmd = do
+-- | Pass an instruction to a `Job`-Worker using the provided callback and block until it was acted upon
-  getResVar <- asks jobConfirm
+writeJobCtlBlock' writeCtl cmd = do
-  resVar <- liftIO . atomically $ do
+  getResVar <- fmap (jobConfirm . jobContext) $ asks appJobState >>= atomically . readTMVar
+  resVar <- atomically $ do
     var <- newEmptyTMVar
     modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
     return var
-  lift $ writeJobCtl cmd
+  writeCtl cmd
   let
     removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd
-  mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
+  mExc <- atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
   maybe (return ()) throwM mExc
 
-queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
+writeJobCtlBlock :: (MonadThrow m, MonadIO m, MonadReader UniWorX m) => JobCtl -> m ()
-queueJobUnsafe job = do
+-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
-  now <- liftIO getCurrentTime
+writeJobCtlBlock = writeJobCtlBlock' writeJobCtl
-  self <- getsYesod appInstanceID
+
+queueJobUnsafe :: Bool -> Job -> YesodDB UniWorX QueuedJobId
+queueJobUnsafe queuedJobWriteLastExec job = do
+  queuedJobCreationTime <- liftIO getCurrentTime
+  queuedJobCreationInstance <- getsYesod appInstanceID
   insert QueuedJob
     { queuedJobContent = toJSON job
-    , queuedJobCreationInstance = self
-    , queuedJobCreationTime = now
     , queuedJobLockInstance = Nothing
     , queuedJobLockTime = Nothing
+    , ..
     }
   -- We should not immediately notify a worker; instead wait for the transaction to finish first
   -- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
@@ -79,18 +97,21 @@ queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
 -- ^ Queue a job for later execution
 --
 -- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
-queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
+queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe False
 
 queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
 -- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
-queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
+queueJob' job = do
+  app <- getYesod
+  queueJob job >>= flip runReaderT app . writeJobCtl . JobCtlPerform
 
 -- | Slightly modified Version of `YesodDB` for `runDBJobs`
 type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
 
-queueDBJob :: Job -> YesodJobDB UniWorX ()
+queueDBJob, queueDBJobCron :: Job -> YesodJobDB UniWorX ()
 -- | Queue a job as part of a database transaction and execute it after the transaction succeeds
-queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
+queueDBJob job = mapReaderT lift (queueJobUnsafe False job) >>= tell . Set.singleton
+queueDBJobCron job = mapReaderT lift (queueJobUnsafe True job) >>= tell . Set.singleton
 
 sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
 -- | Queue many jobs as part of a database transaction and execute them after the transaction passes
@@ -102,5 +123,6 @@ runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -
 -- Jobs get immediately executed if the transaction succeeds
 runDBJobs act = do
   (ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
-  forM_ jIds $ writeJobCtl . JobCtlPerform
+  app <- getYesod
+  forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform
   return ret

src/Jobs/Types.hs

@@ -2,15 +2,24 @@ module Jobs.Types
   ( Job(..), Notification(..)
   , JobCtl(..)
   , JobContext(..)
+  , JobState(..)
+  , jobWorkerNames
+  , JobWorkerId
+  , showWorkerId, newWorkerId
   ) where
 
-import Import.NoFoundation
+import Import.NoFoundation hiding (Unique)
 
 import Data.Aeson (defaultOptions, Options(..), SumEncoding(..))
 import Data.Aeson.TH (deriveJSON)
 
 import Data.List.NonEmpty (NonEmpty)
 
+import Data.Unique
+
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+
 
 data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
          | JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
@@ -37,6 +46,10 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
                          , jInvitationSubject :: Text
                          , jInvitationExplanation :: Html
                          }
+         | JobSendPasswordReset { jRecipient :: UserId
+                                }
+         | JobTruncateTransactionLog
+         | JobDeleteTransactionLogIPs
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetActive { nSheet :: SheetId }
@@ -44,7 +57,9 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
                   | NotificationSheetInactive { nSheet :: SheetId }
                   | NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
                   | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
-                  | NotificationUserRightsUpdate { nUser :: UserId, originalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
+                  | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
+                  | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
+                  | NotificationExamResult { nExam :: ExamId }
   deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Hashable Job
@@ -70,12 +85,35 @@ data JobCtl = JobCtlFlush
             | JobCtlDetermineCrontab
             | JobCtlQueue Job
             | JobCtlGenerateHealthReport HealthCheck
+            | JobCtlNoOp
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance Hashable JobCtl
 
 
+newtype JobWorkerId = JobWorkerId { jobWorkerUnique :: Unique }
+  deriving (Eq, Ord)
+
+showWorkerId :: JobWorkerId -> Text
+-- ^ Make a `JobWorkerId` somewhat human readable as a small-ish Number
+showWorkerId = tshow . hashUnique . jobWorkerUnique
+
+newWorkerId :: MonadIO m => m JobWorkerId
+newWorkerId = JobWorkerId <$> liftIO newUnique
+  
 data JobContext = JobContext
-  { jobCrontab :: TMVar (Crontab JobCtl)
+  { jobCrontab :: TVar (Crontab JobCtl)
   , jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
   }
+
+data JobState = JobState
+  { jobWorkers :: Map (Async ()) (TChan JobCtl)
+  , jobWorkerName :: Async () -> JobWorkerId
+  , jobContext :: JobContext
+  , jobPoolManager :: Async ()
+  , jobCron :: Async ()
+  , jobShutdown :: TMVar ()
+  }
+
+jobWorkerNames :: JobState -> Set JobWorkerId
+jobWorkerNames JobState{..} = Set.map jobWorkerName $ Map.keysSet jobWorkers

src/Language/Haskell/TH/Instances.hs

@@ -7,8 +7,18 @@ module Language.Haskell.TH.Instances
 import Language.Haskell.TH
 import Language.Haskell.TH.Lift (deriveLift)
 import Data.Binary (Binary)
-
+import Data.Semigroup
+import Data.Monoid ()
+import Control.Applicative
 
 instance Binary Loc
 
 deriveLift ''Loc
+
+
+instance Semigroup (Q [Dec]) where
+  (<>) = liftA2 (<>)
+
+instance Monoid (Q [Dec]) where
+  mempty  = pure mempty
+  mappend = (<>)

src/Ldap/Client/Pool.hs

@@ -10,6 +10,8 @@ module Ldap.Client.Pool
 
 import ClassyPrelude
 
+import Control.Lens
+
 import Ldap.Client (Ldap, LdapError)
 import qualified Ldap.Client as Ldap
 
@@ -22,11 +24,17 @@ import Data.Dynamic
 
 import System.Timeout.Lifted
 
+import Control.Concurrent.Async.Lifted.Safe
+import Control.Concurrent.Async.Lifted.Safe.Utils
+import Control.Monad.Trans.Resource (MonadResource)
+import qualified Control.Monad.Trans.Resource as Resource
+
 
 type LdapPool = Pool LdapExecutor
 data LdapExecutor = LdapExecutor
   { ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
   , ldapDestroy :: TMVar ()
+  , ldapAsync :: Async ()
   }
 
 instance Exception LdapError
@@ -41,7 +49,7 @@ withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap
 withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
 
 
-createLdapPool :: ( MonadLoggerIO m, MonadIO m )
+createLdapPool :: ( MonadLoggerIO m, MonadResource m )
                => Ldap.Host
                -> Ldap.PortNumber
                -> Int -- ^ Stripes
@@ -53,15 +61,15 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
   logFunc <- askLoggerIO
   
   let
-    mkExecutor :: IO LdapExecutor
+    mkExecutor :: Resource.InternalState -> IO LdapExecutor
-    mkExecutor = do
+    mkExecutor rSt = Resource.runInternalState ?? rSt $ do
-      ldapDestroy <- newEmptyTMVarIO
+      ldapDestroy <- liftIO newEmptyTMVarIO
-      ldapAct <- newEmptyTMVarIO
+      ldapAct <- liftIO newEmptyTMVarIO
 
       let
         ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
         ldapExec act = do
-          ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
+          ldapAnswer <- liftIO newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
           atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
           either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
           `catches`
@@ -91,10 +99,10 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
                 ]
               go Nothing ldap
 
-      withTimeout $ do
+      ldapAsync <- withTimeout $ do
-        setup <- newEmptyTMVarIO
+        setup <- liftIO newEmptyTMVarIO
 
-        void . fork . flip runLoggingT logFunc $ do
+        ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do
           $logInfoS "LdapExecutor" "Starting"
           res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
           case res of
@@ -105,11 +113,16 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
 
         maybe (return ()) throwM =<< atomically (takeTMVar setup)
 
+        return ldapAsync
+
       return LdapExecutor{..}
 
     delExecutor :: LdapExecutor -> IO ()
-    delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
+    delExecutor LdapExecutor{..} = do
-  liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
+      atomically . void $ tryPutTMVar ldapDestroy ()
+      wait ldapAsync
+  rSt <- view _2 <$> Resource.allocate Resource.createInternalState Resource.closeInternalState
+  liftIO $ createPool (mkExecutor rSt) delExecutor stripes timeoutConn limit
   where
     withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
     withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

src/Model/Migration.hs

@@ -8,6 +8,7 @@ import ClassyPrelude.Yesod
 import Utils (lastMaybe)
 
 import Model
+import Audit.Types
 import Model.Migration.Version
 import qualified Model.Migration.Types as Legacy
 import Data.Map (Map)
@@ -16,9 +17,15 @@ import qualified Data.Map as Map
 import Data.Set ()
 import qualified Data.Set as Set
 
+import qualified Data.Text as Text
+
+import qualified Data.Conduit.List as C
+
 import Database.Persist.Sql
 import Database.Persist.Postgresql
 
+import Control.Monad.Trans.Maybe (MaybeT(..))
+
 import Text.Read (readMaybe)
 import Data.CaseInsensitive (CI)
 
@@ -26,10 +33,17 @@ import Text.Shakespeare.Text (st)
 
 import Control.Monad.Trans.Reader (mapReaderT)
 import Control.Monad.Except (MonadError(..))
-import Utils (exceptT)
+import Utils (exceptT, allM, whenIsJust, guardM)
+import Utils.DB (getKeyBy)
 
 import Numeric.Natural
 
+import qualified Net.IP as IP
+import qualified Net.IPv4 as IPv4
+import qualified Net.IPv6 as IPv6
+
+import Data.Aeson (toJSON)
+
 -- 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)
@@ -61,7 +75,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
 
 migrateAll :: ( MonadLogger m
               , MonadBaseControl IO m
-              , MonadIO m
+              , MonadResource m
               )
            => ReaderT SqlBackend m ()
 migrateAll = do
@@ -86,7 +100,7 @@ migrateAll = do
 requiresMigration :: forall m.
                      ( MonadLogger m
                      , MonadBaseControl IO m
-                     , MonadIO m
+                     , MonadResource m
                      )
                   => ReaderT SqlBackend m Bool
 requiresMigration = mapReaderT (exceptT return return) $ do
@@ -117,7 +131,7 @@ getMissingMigrations :: forall m m'.
                         ( MonadLogger m
                         , MonadBaseControl IO m
                         , MonadIO m
-                        , MonadIO m'
+                        , MonadResource m'
                         )
                      => ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
 getMissingMigrations = do
@@ -134,8 +148,9 @@ getMissingMigrations = do
 -}
 
 
-customMigrations :: ( MonadIO m
+customMigrations :: forall m.
-                    ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
+                    MonadResource m
+                 => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
 customMigrations = Map.fromListWith (>>)
   [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
     , whenM (columnExists "user" "theme") $ do -- New theme format
@@ -318,6 +333,71 @@ customMigrations = Map.fromListWith (>>)
           ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
         |]
     )
+  , ( AppliedMigrationKey [migrationVersion|14.0.0|] [version|15.0.0|]
+    , whenM (tableExists "user") $ do
+        [executeQQ|
+          ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
+          ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
+        |]
+        let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
+            updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
+            splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
+            splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
+              | Just givenName <- Text.stripSuffix surname displayName
+                              <|> Text.stripPrefix surname displayName
+                -> Text.strip givenName
+              | otherwise
+                -> Text.replace surname "…" displayName
+            splitFirstName _ = Nothing
+        runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
+    )
+  , ( AppliedMigrationKey [migrationVersion|15.0.0|] [version|16.0.0|]
+    , whenM (tableExists "transaction_log") $ do
+        [executeQQ|
+          UPDATE transaction_log SET remote = null WHERE remote = #{IP.fromIPv4 IPv4.loopback} OR remote = #{IP.fromIPv6 IPv6.loopback}
+        |]
+
+        [executeQQ|
+          ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
+        |]
+
+        whenM (tableExists "user") $
+          [executeQQ|
+            UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
+          |]
+
+        [executeQQ|
+          ALTER TABLE transaction_log DROP COLUMN initiator;
+          ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator;
+          ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT;
+        |]
+
+        let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] []
+            updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do
+              newT <- case oldT of
+                Legacy.TransactionTermEdit tid
+                  -> return . Just . TransactionTermEdit $ TermKey tid
+                Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
+                  -> runMaybeT $ do
+                    guardM . lift $ tablesExist ["user", "exam", "course"]
+
+                    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+                    eid <- MaybeT . getKeyBy $ UniqueExam cid examn
+                    uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
+                    return $ TransactionExamRegister eid uid
+                Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
+                  -> runMaybeT $ do
+                    guardM . lift $ tablesExist ["user", "exam", "course"]
+
+                    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+                    eid <- MaybeT . getKeyBy $ UniqueExam cid examn
+                    uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
+                    return $ TransactionExamRegister eid uid
+              whenIsJust newT $ \newT' -> 
+                update lid [ TransactionLogInfo =. toJSON newT' ]
+            updateTransactionInfo _ = return ()
+        runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo
+    )
   ]
 
 
@@ -329,6 +409,9 @@ tableExists table = do
     [Just _] -> return True
     _other   -> return False
 
+tablesExist :: MonadIO m => [Text] -> ReaderT SqlBackend m Bool
+tablesExist = flip allM tableExists
+
 tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableIsEmpty table = do
   [rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []

src/Model/Migration/Types.hs

@@ -58,11 +58,36 @@ instance Finite SheetSubmissionMode
 
 nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
 
-
-{- TODO:
-  * RenderMessage instance for newtype(SheetType) if needed
--}
-
-
 deriveJSON defaultOptions ''SheetType
 Current.derivePersistFieldJSON ''SheetType
+
+
+ 
+data Transaction
+  = TransactionTermEdit
+    { transactionTerm   :: Current.TermIdentifier
+    }
+  | TransactionExamRegister
+    { transactionTerm   :: Current.TermIdentifier
+    , transactionSchool :: Current.SchoolShorthand
+    , transactionCourse :: Current.CourseShorthand
+    , transactionExam   :: Current.ExamName
+    , transactionUser   :: Current.UserIdent
+    }
+  | TransactionExamDeregister
+    { transactionTerm   :: Current.TermIdentifier
+    , transactionSchool :: Current.SchoolShorthand
+    , transactionCourse :: Current.CourseShorthand
+    , transactionExam   :: Current.ExamName
+    , transactionUser   :: Current.UserIdent
+    }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+ 
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , tagSingleConstructors = True
+  , sumEncoding = TaggedObject "transaction" "data"
+  } ''Transaction
+
+Current.derivePersistFieldJSON ''Transaction

src/Model/Types/Exam.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-|
 Module: Model.Types.Exam
@@ -11,12 +12,20 @@ module Model.Types.Exam
 import Import.NoModel
 import Model.Types.Common
 
-import Control.Lens
+import qualified Data.Text as Text
+
+import Control.Lens hiding (universe)
+import Utils.Lens.TH
+
+import qualified Data.Csv as Csv
+
+import Database.Persist.Sql
+  
 
 data ExamResult' res = ExamAttended { examResult :: res }
                      | ExamNoShow
                      | ExamVoided
-  deriving (Show, Read, Eq, Ord, Generic, Typeable)
+  deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable)
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece' 1
   , fieldLabelModifier = camelToPathPiece' 1
@@ -25,6 +34,61 @@ deriveJSON defaultOptions
   } ''ExamResult'
 derivePersistFieldJSON ''ExamResult'
 
+makeLenses_ ''ExamResult'
+makePrisms ''ExamResult'
+
+instance PathPiece res => PathPiece (ExamResult' res) where
+  toPathPiece ExamAttended{..} = toPathPiece examResult
+  toPathPiece ExamNoShow       = "no-show"
+  toPathPiece ExamVoided       = "voided"
+
+  fromPathPiece t
+    | t == "no-show" = Just ExamNoShow
+    | t == "voided"  = Just ExamVoided
+    | Just examResult <- fromPathPiece t
+    = Just ExamAttended{..}
+    | otherwise = Nothing
+
+instance Applicative ExamResult' where
+  pure = ExamAttended
+  ExamAttended f <*> ExamAttended x = ExamAttended $ f x
+  ExamAttended _ <*> ExamNoShow     = ExamNoShow
+  ExamAttended _ <*> ExamVoided     = ExamVoided
+  ExamNoShow     <*> _              = ExamNoShow
+  ExamVoided     <*> _              = ExamVoided
+
+instance Semigroup res => Semigroup (ExamResult' res) where
+  ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r'
+  ExamVoided     <> _               = ExamVoided
+  _              <> ExamVoided      = ExamVoided
+  _              <> _               = ExamNoShow
+
+instance Monoid res => Monoid (ExamResult' res) where
+  mempty = ExamAttended mempty
+  ExamAttended r `mappend` ExamAttended r' = ExamAttended $ r `mappend` r'
+  ExamVoided     `mappend` _               = ExamVoided
+  _              `mappend` ExamVoided      = ExamVoided
+  _              `mappend` _               = ExamNoShow
+
+instance Csv.ToField res => Csv.ToField (ExamResult' res) where
+  toField ExamVoided = "voided"
+  toField ExamNoShow = "no-show"
+  toField ExamAttended{..} = Csv.toField examResult
+
+instance Csv.FromField res => Csv.FromField (ExamResult' res) where
+  parseField "voided"  = pure ExamVoided
+  parseField "no-show" = pure ExamNoShow
+  parseField x = ExamAttended <$> Csv.parseField x
+
+instance Universe res => Universe (ExamResult' res) where
+  universe = concat
+    [ pure ExamVoided
+    , pure ExamNoShow
+    , ExamAttended <$> universe
+    ]
+instance Finite res => Finite (ExamResult' res)
+
+
 data ExamBonusRule = ExamNoBonus
                    | ExamBonusPoints
                      { bonusMaxPoints :: Points
@@ -96,14 +160,28 @@ numberGrade = prism toNumberGrade fromNumberGrade
       n   -> Left  n
 
 instance PathPiece ExamGrade where
-  toPathPiece = tshow . (fromRational :: Rational -> Deci) . review numberGrade
+  toPathPiece = toPathPiece . (fromRational :: Rational -> Deci) . review numberGrade
-  fromPathPiece = finiteFromPathPiece
+  fromPathPiece = preview numberGrade . (toRational :: Deci -> Rational) <=< fromPathPiece
 
 pathPieceJSON ''ExamGrade
 pathPieceJSONKey ''ExamGrade
 
-passingGrade :: ExamGrade -> Bool
+instance Csv.ToField ExamGrade where
-passingGrade = (>= Grade40)
+  toField = Csv.toField . toPathPiece
+instance Csv.FromField ExamGrade where
+  parseField x = asum
+    [ parse =<< Csv.parseField x
+    , parse . Text.replace "," "." =<< Csv.parseField x -- Ugh.
+    ]
+    where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece
+
+instance PersistField ExamGrade where
+  toPersistValue = PersistRational . review numberGrade
+  fromPersistValue = maybe (Left "Could not decode Rational to ExamGrade") Right . preview numberGrade <=< fromPersistValue
+
+instance PersistFieldSql ExamGrade where
+  sqlType _ = SqlNumeric 2 1
+
 
 data ExamGradingRule
   = ExamGradingManual
@@ -118,5 +196,29 @@ deriveJSON defaultOptions
   } ''ExamGradingRule
 derivePersistFieldJSON ''ExamGradingRule
 
-type ExamResultPoints = ExamResult' (Maybe Points)
+
-type ExamResultGrade = ExamResult' ExamGrade
+newtype ExamPassed = ExamPassed { examPassed :: Bool }
+  deriving (Read, Show, Generic, Typeable)
+  deriving newtype (Eq, Ord, Enum, Bounded, PersistField, PersistFieldSql)
+
+deriveFinite ''ExamPassed
+finitePathPiece ''ExamPassed ["failed", "passed"]
+makeWrapped ''ExamPassed
+pathPieceCsv ''ExamPassed
+pathPieceJSON ''ExamPassed
+pathPieceJSONKey ''ExamPassed
+
+passingGrade :: Iso' ExamGrade ExamPassed
+-- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10`
+passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed)
+  
+
+type ExamResultPoints = ExamResult' Points
+type ExamResultGrade  = ExamResult' ExamGrade
+type ExamResultPassed = ExamResult' ExamPassed
+
+instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where
+  toField = either Csv.toField Csv.toField
+
+instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where
+  parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint

src/Model/Types/Health.hs

@@ -15,6 +15,7 @@ data HealthCheck
   | HealthCheckLDAPAdmins
   | HealthCheckSMTPConnect
   | HealthCheckWidgetMemcached
+  | HealthCheckActiveJobExecutors
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 instance Universe HealthCheck
 instance Finite HealthCheck
@@ -39,6 +40,8 @@ data HealthReport
     -- ^ Can we connect to the SMTP server and say @NOOP@?
   | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
     -- ^ Can we store values in memcached and retrieve them via HTTP?
+  | HealthActiveJobExecutors { healthActiveJobExecutors :: Maybe Rational }
+    -- ^ Proportion of job executors (excluding the one running the healthcheck) responding within a timeout
   deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
 
 instance NFData HealthReport
@@ -57,6 +60,7 @@ classifyHealthReport HealthLDAPAdmins{}            = HealthCheckLDAPAdmins
 classifyHealthReport HealthHTTPReachable{}         = HealthCheckHTTPReachable
 classifyHealthReport HealthSMTPConnect{}           = HealthCheckSMTPConnect
 classifyHealthReport HealthWidgetMemcached{}       = HealthCheckWidgetMemcached
+classifyHealthReport HealthActiveJobExecutors{}    = HealthCheckActiveJobExecutors
 
 -- | `HealthReport` classified (`classifyHealthReport`) by badness
 --
@@ -84,4 +88,6 @@ healthReportStatus = \case
     | prop <= 0                            -> HealthFailure
   HealthSMTPConnect           (Just False) -> HealthFailure 
   HealthWidgetMemcached       (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
+  HealthActiveJobExecutors    (Just prop )
+    | prop <  1                            -> HealthFailure
   _other                                   -> maxBound -- Minimum badness

src/Model/Types/Mail.hs

@@ -29,6 +29,8 @@ data NotificationTrigger
   | NTCorrectionsAssigned
   | NTCorrectionsNotDistributed
   | NTUserRightsUpdate
+  | NTUserAuthModeUpdate
+  | NTExamResult
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
 
 instance Universe NotificationTrigger
@@ -54,13 +56,15 @@ newtype NotificationSettings = NotificationSettings { notificationAllowed :: Not
 instance Default NotificationSettings where
   def = NotificationSettings $ \case
     NTSubmissionRatedGraded -> True
-    NTSubmissionRated -> False
+    NTSubmissionRated -> True
     NTSheetActive -> True
     NTSheetSoonInactive -> False
     NTSheetInactive -> True
     NTCorrectionsAssigned -> True
     NTCorrectionsNotDistributed -> True
     NTUserRightsUpdate -> True
+    NTUserAuthModeUpdate -> True
+    NTExamResult -> True
 
 instance ToJSON NotificationSettings where
   toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

src/Model/Types/Security.hs

@@ -26,6 +26,8 @@ data AuthenticationMode = AuthLDAP
                         | AuthPWHash { authPWHash :: Text }
   deriving (Eq, Ord, Read, Show, Generic)
 
+instance Hashable AuthenticationMode
+
 deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
@@ -45,6 +47,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthExamRegistered
   | AuthParticipant
   | AuthTime
+  | AuthAllocationTime
   | AuthMaterials
   | AuthOwner
   | AuthRated
@@ -54,6 +57,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthRegisterGroup
   | AuthEmpty
   | AuthSelf
+  | AuthIsLDAP
+  | AuthIsPWHash
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead

src/Model/Types/Sheet.hs

@@ -171,10 +171,10 @@ instance PathPiece SheetFileType where
   fromPathPiece = finiteFromPathPiece
 
 sheetFile2markup :: SheetFileType -> Markup
-sheetFile2markup SheetExercise = iconQuestion
+sheetFile2markup SheetExercise = iconSFTQuestion
-sheetFile2markup SheetHint     = iconHint
+sheetFile2markup SheetHint     = iconSFTHint
-sheetFile2markup SheetSolution = iconSolution
+sheetFile2markup SheetSolution = iconSFTSolution
-sheetFile2markup SheetMarking  = iconMarking
+sheetFile2markup SheetMarking  = iconSFTMarking
 
 -- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
 -- partitionFileType' = groupMap

src/Settings.hs

@@ -118,9 +118,12 @@ data AppSettings = AppSettings
     , appHealthCheckInterval    :: HealthCheck -> Maybe NominalDiffTime
     , appHealthCheckDelayNotify :: Bool
     , appHealthCheckHTTP        :: Bool
+    , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
 
     , appInitialLogSettings     :: LogSettings
 
+    , appTransactionLogIPRetentionTime :: NominalDiffTime
+
     , appReloadTemplates        :: Bool
     -- ^ Use the reload version of templates
     , appMutableStatic          :: Bool
@@ -389,6 +392,7 @@ instance FromJSON AppSettings where
         appHealthCheckInterval    <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
         appHealthCheckDelayNotify <- o .:  "health-check-delay-notify"
         appHealthCheckHTTP        <- o .:  "health-check-http"
+        appHealthCheckActiveJobExecutorsTimeout <- o .:  "health-check-active-job-executors-timeout"
 
         appSessionTimeout         <- o .: "session-timeout"
 
@@ -403,6 +407,8 @@ instance FromJSON AppSettings where
 
         appInitialLogSettings     <- o .:  "log-settings"
 
+        appTransactionLogIPRetentionTime <- o .:  "ip-retention-time"
+
         appUserDefaults           <- o .:  "user-defaults"
         appAuthPWHash             <- o .:  "auth-pw-hash"
 

src/Text/Blaze/Instances.hs

@@ -14,6 +14,8 @@ import Data.Hashable (Hashable(..))
 import Data.Aeson (ToJSON(..), FromJSON(..))
 import qualified Data.Aeson as Aeson
 
+import qualified Data.Csv as Csv
+
 
 instance Eq Markup where
   (==) = (==) `on` Text.renderMarkup
@@ -35,3 +37,9 @@ instance ToJSON Markup where
 
 instance FromJSON Markup where
   parseJSON = Aeson.withText "Html" $ return . preEscapedText
+
+instance Csv.ToField Markup where
+  toField = Csv.toField . Text.renderMarkup
+
+instance Csv.FromField Markup where
+  parseField = fmap preEscapedText . Csv.parseField

src/Utils.hs

@@ -23,9 +23,12 @@ import Utils.TH as Utils
 import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
 import Utils.Route as Utils
+import Utils.Icon as Utils
 import Utils.Message as Utils
 import Utils.Lang as Utils
 import Utils.Parameters as Utils
+import Utils.Csv as Utils
+import Control.Concurrent.Async.Lifted.Safe.Utils as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -79,9 +82,10 @@ import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, Bounded
 
 import Data.Constraint (Dict(..))
 
-{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
+{-# ANN module ("HLint: ignore Use asum" :: String) #-}
 
 
+$(iconShortcuts) -- declares constants for all known icons
 
 -----------
 -- Yesod --
@@ -112,122 +116,10 @@ unsupportedAuthPredicate = do
         unauthorizedI (UnsupportedAuthPredicate (toPathPiece tag) route)
     |]
 
-
+-- | allows conditional attributes in hamlet via *{..} syntax
-
+maybeAttribute :: Text -> (a -> Text) -> Maybe a -> [(Text,Text)]
--- | A @Widget@ for any site; no language interpolation, etc.
+maybeAttribute _ _ Nothing  = []
-type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBaseControl IO m)
+maybeAttribute a c (Just v) = [(a,c v)]
-  => WidgetT site m ()
-
-
------------
--- Icons --
------------
-
--- Create an icon from font-awesome without additional space
-fontAwesomeIcon :: Text -> Markup
-fontAwesomeIcon iconName =
-  [shamlet|$newline never
-            <i .fas .fa-#{iconName}>|]
-
--- We collect all used icons here for an overview.
--- For consistency, some conditional icons are also provided, e.g. `isIvisble`
-
-iconQuestion :: Markup
-iconQuestion = fontAwesomeIcon "question-circle"
-
-iconNew :: Markup
-iconNew = fontAwesomeIcon "seedling"
-
-iconOK :: Markup
-iconOK = fontAwesomeIcon "check"
-
-iconNotOK :: Markup
-iconNotOK = fontAwesomeIcon "times"
-
-iconWarning :: Markup
-iconWarning = fontAwesomeIcon "exclamation"
-
-iconProblem :: Markup
-iconProblem = fontAwesomeIcon "bolt"
-
-iconHint :: Markup
-iconHint = fontAwesomeIcon "life-ring"
-
--- Icons for Course
-iconCourse :: Markup
-iconCourse = fontAwesomeIcon "graduation-cap"
-
-iconExam :: Markup
-iconExam = fontAwesomeIcon "file-invoice"
-
-iconEnrol :: Bool -> Markup
-iconEnrol True  = fontAwesomeIcon "user-plus"
-iconEnrol False = fontAwesomeIcon "user-slash"
-
-iconExamRegister :: Bool -> Markup
-iconExamRegister True  = fontAwesomeIcon "calendar-check"
-iconExamRegister False = fontAwesomeIcon "calendar-times"
-
-
--- Icons for SheetFileType
-iconSolution :: Markup
-iconSolution =fontAwesomeIcon "exclamation-circle"
-
-iconMarking :: Markup
-iconMarking = fontAwesomeIcon "check-circle"
-
-fileDownload :: Markup
-fileDownload = fontAwesomeIcon "file-download"
-
-zipDownload :: Markup
-zipDownload = fontAwesomeIcon "file-archive"
-
-iconCSV :: Markup
-iconCSV = fontAwesomeIcon "file-csv"
-
-
--- Generic Conditional icons
-
-isVisible :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is visible or invisible
-isVisible True  = fontAwesomeIcon "eye"
-isVisible False = fontAwesomeIcon "eye-slash"
---
--- For documentation on how to avoid these unneccessary functions
--- we implement them here just once for the first icon:
---
-isVisibleWidget :: Bool -> WidgetSiteless
--- ^ Widget having an icon that denotes that something™ is visible or invisible
-isVisibleWidget = toWidget . isVisible
-
-maybeIsVisibleWidget :: Maybe Bool -> WidgetSiteless
--- ^ Maybe a widget with an icon that denotes that something™ is visible or invisible
-maybeIsVisibleWidget = toWidget . foldMap isVisible
-
--- Other _frequently_ used icons:
-hasComment :: Bool -> Markup
--- ^ Display an icon that denotes that something™ has a comment or not
-hasComment True  = fontAwesomeIcon "comment-alt"
-hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free
-
-hasTickmark :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is okay
-hasTickmark True  = iconOK
-hasTickmark False = mempty
-
-isBad :: Bool -> Markup
--- ^ Display an icon that denotes that something™ is bad
-isBad True  = iconProblem
-isBad False = mempty
-
-isNew :: Bool -> Markup
-isNew True  = iconNew
-isNew False = mempty
-
-boolSymbol :: Bool -> Markup
-boolSymbol True  = iconOK
-boolSymbol False = iconNotOK
-
 
 
 ---------------------

src/Utils/Csv.hs

@@ -0,0 +1,19 @@
+module Utils.Csv
+  ( pathPieceCsv
+  ) where
+
+import ClassyPrelude
+import Data.Csv hiding (Name)
+  
+import Language.Haskell.TH (Name)
+import Language.Haskell.TH.Lib
+
+
+pathPieceCsv :: Name -> DecsQ
+pathPieceCsv (conT -> t) =
+  [d|
+    instance ToField $(t) where
+      toField = toField . toPathPiece
+    instance FromField $(t) where
+      parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
+  |]

src/Utils/DB.hs

@@ -11,6 +11,8 @@ import qualified Database.Esqueleto as E
 -- import Database.Persist -- currently not needed here
 
 import Utils
+import Control.Lens
+import Control.Lens.Extras (is)
 
 
 
@@ -27,14 +29,20 @@ entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal ent
 getKeyBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m (Maybe (Key record))
 getKeyBy u = fmap entityKey <$> getBy u -- TODO optimize this, so that DB does not deliver entire record!
+  
+getKeyJustBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m, MonadThrow m, Show (Unique record))
+             => Unique record -> ReaderT backend m (Key record)
+getKeyJustBy u = getKeyBy u >>= maybe
+  (throwM . PersistForeignConstraintUnmet $ tshow u)
+  return
 
-getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadHandler m)
             => Unique record -> ReaderT backend m (Key record)
-getKeyBy404 = fmap entityKey . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
+getKeyBy404 u = getKeyBy u >>= maybe notFound return
 
 existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
          => Unique record -> ReaderT backend m Bool
-existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
+existsBy = fmap (is _Just) . getKeyBy
 
 existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
           => Key record -> ReaderT backend m Bool

src/Utils/DateTime.hs

@@ -6,6 +6,8 @@ module Utils.DateTime
   , currentYear
   , DateTimeFormat(..)
   , SelDateTimeFormat(..)
+  , nominalHour, nominalMinute
+  , minNominalYear, avgNominalYear
   , module Data.Time.Zones
   , module Data.Time.Zones.TH
   ) where
@@ -13,7 +15,7 @@ module Utils.DateTime
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (TimeLocale(..))
+import Data.Time (TimeLocale(..), NominalDiffTime, nominalDay)
 import Data.Time.Zones (TZ)
 import Data.Time.Zones.TH (includeSystemTZ)
 
@@ -117,3 +119,20 @@ instance BoundedMeetSemiLattice SelDateTimeFormat where
   top = SelFormatDateTime
 
 instance BoundedLattice SelDateTimeFormat
+
+
+---------------------
+-- NominalDiffTime --
+---------------------
+
+-- | One hour in `NominalDiffTime`.
+nominalHour :: NominalDiffTime
+nominalHour = 3600
+
+-- | One minute in `NominalDiffTime`.
+nominalMinute :: NominalDiffTime
+nominalMinute = 60
+
+minNominalYear, avgNominalYear :: NominalDiffTime
+minNominalYear = 365 * nominalDay
+avgNominalYear = fromRational $ 365.2425 * toRational nominalDay

src/Utils/Form.hs

@@ -4,7 +4,7 @@
 
 module Utils.Form where
 
-import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
+import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm)
 import Yesod.Core.Instances ()
 import Settings
 
@@ -25,7 +25,7 @@ import qualified Data.Set as Set
 
 import Control.Monad.Trans.Maybe (MaybeT(..))
 import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
+import Control.Monad.Writer.Class (MonadWriter(..), censor)
 import Control.Monad.State.Class (MonadState(..))
 import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
 import Control.Monad.Trans.Except (ExceptT, runExceptT)
@@ -210,6 +210,7 @@ data FormIdentifier
   | FIDUserDelete
   | FIDCommunication
   | FIDAssignSubmissions
+  | FIDUserAuthMode
   deriving (Eq, Ord, Read, Show)
 
 instance PathPiece FormIdentifier where
@@ -616,6 +617,50 @@ fileFieldMultiple = Field
   , fieldEnctype = Multipart
   }
 
+checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b) -> (b -> a) -> Field m a -> Field m b
+checkMap f = checkMMap (return . f)
+
+
+selectField' :: ( Eq a
+                , RenderMessage (HandlerSite m) FormMessage
+                , MonadHandler m
+                )
+             => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
+             -> HandlerT (HandlerSite m) IO (OptionList a)
+             -> Field m a
+-- ^ Like @selectField@, but with more control over the @Nothing@-Option, if Field is optional
+selectField' optMsg mkOpts = Field{..}
+  where
+    fieldEnctype = UrlEncoded
+
+    fieldParse []    _ = return $ Right Nothing
+    fieldParse (s:_) _
+      | s == ""     = return $ Right Nothing
+      | otherwise = do
+          OptionList{olReadExternal} <- liftHandlerT mkOpts
+          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s
+
+    fieldView theId name attrs val isReq = do
+      OptionList{olOptions} <- liftHandlerT mkOpts
+      let
+        rendered = case val of
+          Left  _ -> ""
+          Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions
+
+        isSel Nothing    = not $ rendered `elem` map optionExternalValue olOptions
+        isSel (Just opt) = rendered == optionExternalValue opt
+      [whamlet|
+        $newline never
+        <select ##{theId} name=#{name} *{attrs} :isReq:required>
+          $maybe optMsg' <- assertM (const $ not isReq) optMsg
+            <option value="" :isSel Nothing:selected>
+              _{optMsg'}
+          $forall opt <- olOptions
+            <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+              #{optionDisplay opt}
+      |]
+
+
 -----------
 -- Forms --
 -----------
@@ -751,15 +796,15 @@ wformMessage :: (MonadHandler m) => Message -> WForm m ()
 wformMessage = void . aFormToWForm . aformMessage
 
 formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
-formMessage Message{..} = do
+formMessage Message{ messageIcon = _, ..} = do -- custom icons are not currently implemented for `.notification`
-    return (FormSuccess (), FieldView
+  return (FormSuccess (), FieldView
-      { fvLabel    = mempty
+    { fvLabel    = mempty
-      , fvTooltip  = Nothing
+    , fvTooltip  = Nothing
-      , fvId       = idFormMessageNoinput
+    , fvId       = idFormMessageNoinput
-      , fvErrors   = Nothing
+    , fvErrors   = Nothing
-      , fvRequired = False
+    , fvRequired = False
-      , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
+    , fvInput    = [whamlet|<div .notification .notification-#{toPathPiece messageStatus}>#{messageContent}|]
-      })
+    })
 
 ---------------------
 -- Form evaluation --
@@ -891,7 +936,7 @@ guardValidation :: ( MonadHandler m
                 => msg -- ^ Message describing violation
                 -> Bool -- ^ @False@ iff constraint is violated
                 -> FormValidator r m ()
-guardValidation msg isValid = when (not isValid) $ tellValidationError msg
+guardValidation msg isValid = unless isValid $ tellValidationError msg
 
 guardValidationM :: ( MonadHandler m
                     , RenderMessage (HandlerSite m) msg
@@ -899,6 +944,16 @@ guardValidationM :: ( MonadHandler m
                  => msg -> m Bool -> FormValidator r m ()
 guardValidationM = (. lift) . (=<<) . guardValidation
 
+-- | like `guardValidation`, but issues a warning instead
+warn_Validation :: ( MonadHandler m
+                   , RenderMessage (HandlerSite m) msg
+                   )
+                => msg -- ^ Message describing violation
+                -> Bool -- ^ @False@ iff constraint is violated
+                -> FormValidator r m ()
+warn_Validation msg isValid = unless isValid $ addMessageI Warning msg
+
+
 -----------------------
 -- Form Manipulation --
 -----------------------
@@ -915,6 +970,10 @@ infixl 4 `fmapAForm`
 fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
 fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
 
+wFormFields :: Monad m => WForm m a -> WForm m (a, [FieldView (HandlerSite m)])
+-- ^ Suppress side effect of appending `FieldView`s and instead add them to the result
+wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (const mempty) . listen)
+
 ---------------------------------------------
 -- Special variants of @mopt@, @mreq@, ... --
 ---------------------------------------------
@@ -942,6 +1001,10 @@ aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m
         => Field m a -> FieldSettings site -> a -> AForm m a
 aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
 
+wforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> WForm m (FormResult a)
+wforced field settings val = mFormToWForm $ mforced field settings val
+
 mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
 -- ^ Pseudo required