diff --git a/CHANGELOG.md b/CHANGELOG.md index ce0147d38..20d6b9b50 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/config/settings.yml b/config/settings.yml index edd971e64..bcd9cabcb 100644 --- a/config/settings.yml +++ b/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" diff --git a/default.nix b/default.nix index 21608bb19..aa23072f4 100644 --- a/default.nix +++ b/default.nix @@ -1,6 +1,6 @@ argumentPackages@{ ... }: let - defaultPackages = (import {}).haskellPackages; + defaultPackages = (import ./stackage.nix {}); haskellPackages = defaultPackages // argumentPackages; in import ./uniworx.nix { inherit (haskellPackages) callPackage; } diff --git a/frontend/src/utils/alerts/alerts.js b/frontend/src/utils/alerts/alerts.js index e7e04ddbb..3c4eba683 100644 --- a/frontend/src/utils/alerts/alerts.js +++ b/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); diff --git a/frontend/src/utils/alerts/alerts.scss b/frontend/src/utils/alerts/alerts.scss index d2faf1b22..aa2f6acdc 100644 --- a/frontend/src/utils/alerts/alerts.scss +++ b/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 { - content: '\f058'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f058'; + * } + */ } .alert-warning { background-color: var(--color-warning); - .alert__icon::before { - content: '\f06a'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f06a'; + * } + */ } .alert-error { background-color: var(--color-error); - .alert__icon::before { - content: '\f071'; - } + /* .alert__icon::before { + * --alert-icon-default: '\f071'; + * } + */ } diff --git a/frontend/src/utils/form/interactive-fieldset.js b/frontend/src/utils/form/interactive-fieldset.js index 916c01aa3..5d24ee9c2 100644 --- a/frontend/src/utils/form/interactive-fieldset.js +++ b/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!'); diff --git a/is-clean.sh b/is-clean.sh new file mode 100755 index 000000000..b63b54f46 --- /dev/null +++ b/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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 86cd283e6..1875d51fa 100644 --- a/messages/uniworx/de.msg +++ b/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 -CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname) +CsvColumnExamUserSurname: Nachname(n) des Teilnehmers +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 \ No newline at end of file +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 diff --git a/models/allocations b/models/allocations new file mode 100644 index 000000000..71341e876 --- /dev/null +++ b/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) diff --git a/models/audit b/models/audit index 5c9c10ef7..ecff023f5 100644 --- a/models/audit +++ b/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` --- 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 \ No newline at end of file + info Value -- JSON-encoded `Transaction` \ No newline at end of file diff --git a/models/courses b/models/courses index 5be19103a..1376af569 100644 --- a/models/courses +++ b/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 diff --git a/models/exams b/models/exams index a98a427ca..694f1a9bc 100644 --- a/models/exams +++ b/models/exams @@ -47,6 +47,7 @@ ExamResult exam ExamId user UserId result ExamResultGrade + lastChanged UTCTime default=now() UniqueExamResult exam user ExamCorrector exam ExamId diff --git a/models/jobs b/models/jobs index fcf0006b8..06be9fbeb 100644 --- a/models/jobs +++ b/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@ diff --git a/models/users b/models/users index f0b3e683e..33a92adf1 100644 --- a/models/users +++ b/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 diff --git a/nixpkgs.nix b/nixpkgs.nix new file mode 100644 index 000000000..f21a81350 --- /dev/null +++ b/nixpkgs.nix @@ -0,0 +1,9 @@ +{ nixpkgs ? import +}: + +import ((nixpkgs {}).fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "19.03"; + sha256 = "0q2m2qhyga9yq29yz90ywgjbn9hdahs7i8wwlq7b55rdbyiwa5dy"; +}) diff --git a/package-lock.json b/package-lock.json index 49c5066b7..dfb2e66cb 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "4.2.0", + "version": "4.12.1", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 60dfd1f05..8706e68c0 100644 --- a/package.json +++ b/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" }, diff --git a/package.yaml b/package.yaml index cf631c001..cec8e434e 100644 --- a/package.yaml +++ b/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 diff --git a/routes b/routes index 3b1aa5262..8ebe100e7 100644 --- a/routes +++ b/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 diff --git a/shell.nix b/shell.nix index b942f99b9..d65bb65a3 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -{ nixpkgs ? import }: +{ nixpkgs ? import ./nixpkgs.nix {} }: let inherit (nixpkgs {}) pkgs; diff --git a/src/Application.hs b/src/Application.hs index 3e20e6613..7291fda1c 100644 --- a/src/Application.hs +++ b/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 - appCronThread <- liftIO newEmptyTMVarIO + appJobState <- 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 diff --git a/src/Audit.hs b/src/Audit.hs index a3c7d623a..ac8270edf 100644 --- a/src/Audit.hs +++ b/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 - 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 + + if + | ipFromHeader + , 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 - , AuthEntity site ~ User - , IsSqlBackend (YesodPersistBackend site) - , SqlBackendCanWrite (YesodPersistBackend site) - , HasInstanceID site InstanceId - , YesodAuthPersist site +audit :: ( AuthId (HandlerSite m) ~ Key User + , AuthEntity (HandlerSite m) ~ User + , IsSqlBackend (YesodPersistBackend (HandlerSite m)) + , SqlBackendCanWrite (YesodPersistBackend (HandlerSite m)) + , HasInstanceID (HandlerSite m) InstanceId + , YesodAuthPersist (HandlerSite m) + , MonadHandler m + , MonadCatch m + , HasAppSettings (HandlerSite m) ) => Transaction -- ^ Transaction to record - -> [UserId] -- ^ Affected users - -> YesodDB site () + -> ReaderT (YesodPersistBackend (HandlerSite m)) m () -- ^ 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 - uid <- liftHandlerT maybeAuthId +audit (toJSON -> transactionLogInfo) = do 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{..} - - 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 [] + insert_ TransactionLog{..} diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index 5ffabcd09..493b8b1b7 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -12,21 +12,23 @@ import Utils.PathPiece data Transaction = TransactionTermEdit - { transactionTerm :: TermIdentifier + { transactionTerm :: TermId } | TransactionExamRegister - { transactionTerm :: TermIdentifier - , transactionSchool :: SchoolShorthand - , transactionCourse :: CourseShorthand - , transactionExam :: ExamName - , transactionUser :: UserIdent + { transactionExam :: ExamId + , transactionUser :: UserId } | TransactionExamDeregister - { transactionTerm :: TermIdentifier - , transactionSchool :: SchoolShorthand - , transactionCourse :: CourseShorthand - , transactionExam :: ExamName - , transactionUser :: UserIdent + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamResultEdit + { transactionExam :: ExamId + , transactionUser :: UserId + } + | TransactionExamResultDeleted + { transactionExam :: ExamId + , transactionUser :: UserId } deriving (Eq, Ord, Read, Show, Generic, Typeable) diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 4f003471a..26026dfee 100644 --- a/src/Auth/LDAP.hs +++ b/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 - , userPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 ident - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] - , userEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] - , userDisplayName Ldap.:= Text.encodeUtf8 ident + [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident + , ldapUserPrincipalName Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 ident + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@lmu.de|] + , ldapUserEmail Ldap.:= Text.encodeUtf8 [st|#{ident}@campus.lmu.de|] + , 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 -userPrincipalName = Ldap.Attr "userPrincipalName" -userEmail = Ldap.Attr "mail" -userDisplayName = Ldap.Attr "displayName" +ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName, ldapUserMatriculation, ldapUserFirstName, ldapUserSurname, ldapUserTitle, ldapUserStudyFeatures, ldapUserFieldName :: Ldap.Attr +ldapUserPrincipalName = Ldap.Attr "userPrincipalName" +ldapUserEmail = Ldap.Attr "mail" +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" diff --git a/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs b/src/Control/Concurrent/Async/Lifted/Safe/Utils.hs new file mode 100644 index 000000000..27dc86127 --- /dev/null +++ b/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 diff --git a/src/Cron.hs b/src/Cron.hs index 53a7a01b3..5017e71d1 100644 --- a/src/Cron.hs +++ b/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 - | otherwise = fromWeekDate (pred y) 53 dow + | w > 1 = fromWeekDate y (pred w) 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 _ _ _ CronMatchNone = [] -genMatch p m _ (CronMatchSome xs) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable xs -genMatch p m st (CronMatchStep step) = do +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 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 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..] -genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to] -genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = [] -genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = [] -genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other -genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other -genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) - = genMatch p m st . CronMatchStep $ lcm st1 st2 -genMatch p m st (CronMatchIntersect aGen bGen) + 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 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 p m z st (CronMatchIntersect CronMatchAny other) = genMatch p m z st other +genMatch p m z st (CronMatchIntersect other CronMatchAny) = genMatch p m z st other +genMatch p m z st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2)) + = genMatch p m z st . CronMatchStep $ lcm st1 st2 +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 st (CronMatchUnion other CronMatchNone) = genMatch p m st other -genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny -genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m 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 CronMatchNone other) = genMatch p m z st other +genMatch p m z st (CronMatchUnion other CronMatchNone) = genMatch p m z st other +genMatch p m z st (CronMatchUnion CronMatchAny _) = genMatch p m z st CronMatchAny +genMatch p m z st (CronMatchUnion _ CronMatchAny) = genMatch p m z st CronMatchAny +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 diff --git a/src/Cron/Types.hs b/src/Cron/Types.hs index ab3e92972..576796038 100644 --- a/src/Cron/Types.hs +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index f170302a0..4259cb2fd 100644 --- a/src/CryptoID.hs +++ b/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 diff --git a/src/Data/Fixed/Instances.hs b/src/Data/Fixed/Instances.hs index 53696e9e6..7593400e3 100644 --- a/src/Data/Fixed/Instances.hs +++ b/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 diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs new file mode 100644 index 000000000..85c46f844 --- /dev/null +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a3bf2192a..5a032a6de 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 - \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1)) +orderByOrd = orderByList $ List.sort universeF 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" diff --git a/src/Foundation.hs b/src/Foundation.hs index 1a5bd92b4..8070aa3d0 100644 --- a/src/Foundation.hs +++ b/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)) - , appCronThread :: TMVar (ReleaseKey, ThreadId) + , appJobState :: TMVar JobState , 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 - Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content - addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs' + lift . bracketOnError getMessages (mapM_ addMessage') $ + addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict . JSON.encode -- 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) = [ - MenuItem +pageActions (UsersR) = + [ 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 - addMessage Error (toHtml $ tshow (err :: CampusUserException)) - $logErrorS "LDAP" $ tshow err - acceptExisting - ] + = do + case res of + UserError err -> addMessageI Error err + ServerError err -> addMessage Error $ toHtml err + _other -> return () + acceptExisting | otherwise - = [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent - return . UserError $ IdentifierNotFound credsIdent - err -> do - $logErrorS "LDAP" $ tshow err - return $ ServerError "LDAP lookup failed" - ] + = return res + + excHandlers = + [ C.Handler $ \case + CampusUserNoResult -> do + $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + excRecovery . UserError $ IdentifierNotFound credsIdent + CampusUserAmbiguous -> do + $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + 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 - ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (original userIdent) credsExtra + Just (ldapConf, ldapPool) -> do + let userCreds = Creds credsPlugin (original userIdent) credsExtra + ldapData <- campusUser ldapConf ldapPool userCreds $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData - - let - userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData - 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 ()) + Authenticated . entityKey <$> upsertCampusUser ldapData userCreds + Nothing + -> acceptExisting 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 diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index a2f4eafa3..27fc5c809 100644 --- a/src/Handler/Admin.hs +++ b/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` diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2c0a74755..aae2bc46a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -1,1430 +1,20 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Handler.Course where +module Handler.Course + ( module Handler.Course + ) where import Import -import Utils.Lens -import Utils.Form --- import Utils.DB -import Handler.Utils -import Handler.Utils.Course -import Handler.Utils.Tutorial -import Handler.Utils.Communication -import Handler.Utils.Delete -import Handler.Utils.Database -import Handler.Utils.Table.Cells -import Handler.Utils.Table.Columns -import Handler.Utils.Table.Pagination (DBSTemplateMode(..)) -import Handler.Utils.Invitations -import Database.Persist.Sql (deleteWhereCount) -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH --- import Data.Time -import qualified Data.CaseInsensitive as CI -import Data.Function ((&)) --- import Yesod.Form.Bootstrap3 - -import Data.Maybe (fromJust) -import qualified Data.Set as Set -import Data.Map ((!)) -import qualified Data.Map as Map - -import qualified Database.Esqueleto as E - -import Text.Blaze.Html.Renderer.Text (renderHtml) - -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) - - --- 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}|] - - --- 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}|] - --- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) --- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do --- course <- view $ _dbrOutput . _1 . _entityVal --- return $ courseCell course - -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}|] - --- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) --- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) --- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend --- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) --- ( case courseDescription of --- Nothing -> mempty --- (Just descr) -> cell --- [whamlet| --- $newline never ---
--- ^{modal "Beschreibung" (Right $ toWidget descr)} --- |] --- ) - -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}|] - -colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}, _) } -> - anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolName}|] - -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}|] - -colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> - maybe mempty dateTimeCell courseRegisterFrom - -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget - -colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _, _) } -> - maybe mempty dateTimeCell courseRegisterTo - -colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a) -colMembers = sortable (Just "members") (i18nCell MsgCourseMembers) - $ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _, _) } -> i18nCell $ case courseCapacity of - Nothing -> MsgCourseMembersCount currentParticipants - Just limit -> MsgCourseMembersCountLimited currentParticipants limit - -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.^. SchoolId -- TODO: Refactor all?! - -- E.mkExactFilter $ $(sqlIJproj 2 2) >>> (E.^. SchoolId) - ) - , ( "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)]) - -getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCShowR tid ssh csh = do - mbAid <- maybeAuthId - (cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- 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 ) - return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors) - - 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 -
    - $forall tutor <- tutTutors -
  • - ^{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") - --- | 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 - addMessageI Info MsgCourseDeregisterOk - | codeOk -> do - actTime <- liftIO getCurrentTime - regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId - when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk - | otherwise -> addMessageI Warning MsgCourseSecretWrong - -- addMessage Info $ toHtml $ show regResult -- For debugging only - redirect $ CourseR tid ssh csh CShowR - - -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 [] [] 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 - return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites - -- 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 3) courseToForm <$> courseData - - -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 - } - - --- | 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 - 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 - 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 - } - - -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 Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand - invitationHeading 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 - invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do - MsgRenderer mr <- getMsgRenderer - return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand - invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR - - -data CourseForm = CourseForm - { cfCourseId :: Maybe CourseId - , cfName :: CourseName - , cfDesc :: Maybe Html - , cfLink :: Maybe Text - , cfShort :: CourseShorthand - , cfTerm :: TermId - , cfSchool :: SchoolId - , cfCapacity :: Maybe Int - , cfSecret :: Maybe Text - , cfMatFree :: Bool - , cfRegFrom :: Maybe UTCTime - , cfRegTo :: Maybe UTCTime - , cfDeRegUntil :: Maybe UTCTime - , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] - } - -courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm -courseToForm (Entity cid Course{..}) lecs lecInvites = 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 - , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] - ++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ] - } - -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 ) - - (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm - <$> pure (cfCourseId =<< template) - <*> areq ciField (fslI MsgCourseName) (cfName <$> template) - <*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben" - & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) - <*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL") - (cfLink <$> template) - <*> areq ciField (fslI MsgCourseShorthand - -- & addAttr "disabled" "disabled" - & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template) - <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) - <*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity - & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) - <*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat) - & setTooltip MsgCourseSecretTip) (cfSecret <$> template) - <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> 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) - <*> lecturerForm - errorMsgs' <- traverse validateCourse result - return $ case errorMsgs' of - FormSuccess errorMsgs - | not $ null errorMsgs -> - (FormFailure errorMsgs, - [whamlet| -
    -
    -

    Fehler: -
      - $forall errmsg <- errorMsgs -
    • #{errmsg} - ^{widget} - |] - ) - _ -> (result, widget) - - -validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text] -validateCourse CourseForm{..} = do - 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 - - 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 - ) - ] ] - - - --------------------- --- CourseUserTable - -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 - -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 - -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") - - - -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") - - -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 -
      - _{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 - addMessageI Info 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 - case pId of - Just _ -> do - addMessageI Success 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") +import Handler.Course.Communication as Handler.Course +import Handler.Course.Delete as Handler.Course +import Handler.Course.Edit as Handler.Course +import Handler.Course.LecturerInvite as Handler.Course +import Handler.Course.List as Handler.Course +import Handler.Course.ParticipantInvite as Handler.Course +import Handler.Course.Register as Handler.Course +import Handler.Course.Show as Handler.Course +import Handler.Course.User as Handler.Course +import Handler.Course.Users as Handler.Course getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -1435,214 +25,4 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- PROBLEM: Correctors usually don't know Participants by name (anonymous), maybe notes are not shared? -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = postCNotesR -postCNotesR _ _ _ = do - defaultLayout $ [whamlet|You have corrector access to this course.|] - - -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 - } - - -getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -getCLecInviteR = postCLecInviteR -postCLecInviteR = invitationR lecturerInvitationConfig - - - --- Invitations for ordinary participants of this course -instance IsInvitableJunction CourseParticipant where - type InvitationFor CourseParticipant = Course - data InvitableJunction CourseParticipant = JunctionParticipant - { jParticipantRegistration :: UTCTime - , jParticipantFild :: Maybe StudyFeaturesId - } 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)) - (\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..}) - - ephemeralInvitation = Just (iso (const InvDBDataParticipant) (const ())) - -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 { fieldLabelModifier = 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 Course{..} _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand - invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName - invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|] - -- Keine besonderen Einschränkungen beim Einlösen der Token - -- ACHTUNG: Mit einem Token könnten sich deshalb mehrere Benutzer anmelden! - invitationTokenConfig _ _ = do - itAuthority <- liftHandlerT requireAuthId - return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing - invitationRestriction _ _ = return Authorized - invitationForm Course{..} _ uid = hoistAForm lift . wFormToAForm $ do - now <- liftIO getCurrentTime - studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) - (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing - return $ JunctionParticipant <$> pure now <*> studyFeatures - invitationSuccessMsg Course{..} _ = - return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) - invitationUltDest 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 alreadyRegistered registeredNoField registeredOneField <- 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 - - when (not $ null emails) $ - tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails - - when (not $ null alreadyRegistered) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}|] - modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") - tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) - - when (not $ null registeredNoField) $ do - let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}|] - modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField") - tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent) - - when (not $ null registeredOneField) $ - tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length registeredOneField - - 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 - , .. - } - - 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 +postCNotesR _ _ _ = defaultLayout [whamlet|You have corrector access to this course.|] diff --git a/src/Handler/Course/Communication.hs b/src/Handler/Course/Communication.hs new file mode 100644 index 000000000..a7fb00ac8 --- /dev/null +++ b/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 + } diff --git a/src/Handler/Course/Delete.hs b/src/Handler/Course/Delete.hs new file mode 100644 index 000000000..ce238c406 --- /dev/null +++ b/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 + } diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs new file mode 100644 index 000000000..8cb6a1bb5 --- /dev/null +++ b/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| +
      +
      +

      Fehler: +
        + $forall errmsg <- errorMsgs +
      • #{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 () diff --git a/src/Handler/Course/LecturerInvite.hs b/src/Handler/Course/LecturerInvite.hs new file mode 100644 index 000000000..25086ff1b --- /dev/null +++ b/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 + diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs new file mode 100644 index 000000000..f94ad982e --- /dev/null +++ b/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)]) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs new file mode 100644 index 000000000..529f64fc6 --- /dev/null +++ b/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 diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs new file mode 100644 index 000000000..542e617d2 --- /dev/null +++ b/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 diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs new file mode 100644 index 000000000..d5b24b951 --- /dev/null +++ b/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 +
          + $forall tutor <- tutTutors +
        • + ^{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") diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs new file mode 100644 index 000000000..0fa340a08 --- /dev/null +++ b/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 +
          + _{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") diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs new file mode 100644 index 000000000..c7e0f1378 --- /dev/null +++ b/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") diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index e8c2b8ea4..6580c90f4 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -1,1316 +1,13 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Handler.Exam where - -import Import - -import Handler.Utils -import Handler.Utils.Exam -import Handler.Utils.Invitations -import Handler.Utils.Table.Columns -import Handler.Utils.Table.Cells -import Handler.Utils.Csv -import Jobs.Queue - -import Utils.Lens hiding (parts) - -import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Utils as E -import Database.Esqueleto.Utils.TH - -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 Data.Aeson hiding (Result(..)) -import Text.Hamlet (ihamlet) -import Text.Blaze.Html.Renderer.String (renderHtml) - -import qualified Data.CaseInsensitive as CI - -import qualified Control.Monad.State.Class as State -import Control.Arrow (Kleisli(..)) - -import qualified Data.Csv as Csv - -import qualified Data.Conduit.List as C - -import Numeric.Lens (integral) - -import Database.Persist.Sql (deleteWhereCount, updateWhereCount) - - - --- 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}|] - - - -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") - - -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 Exam{..} _ = do - Course{..} <- get404 examCourse - return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName - invitationHeading 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 - invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName - invitationUltDest Exam{..} _ = do - Course{..} <- get404 examCourse - return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR - -getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getECInviteR = postECInviteR -postECInviteR = invitationR examCorrectorInvitationConfig - - -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 - guardValidation (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 - - -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") - -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") - - -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 -> do - 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| -

          - $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") - -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)))) -type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms)) - -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 3 1) - -queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) -queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) -queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) - -queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) -queryExamOccurrence = $(sqlLOJproj 3 2) - -queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) -queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) -queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - -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 - -data ExamUserTableCsv = ExamUserTableCsv - { csvEUserSurname :: Maybe Text - , csvEUserName :: Maybe Text - , csvEUserMatriculation :: Maybe Text - , csvEUserField :: Maybe Text - , csvEUserDegree :: Maybe Text - , csvEUserSemester :: Maybe Int - , csvEUserOccurrence :: Maybe (CI Text) - , csvEUserExercisePoints :: Maybe Points - , csvEUserExercisePasses :: Maybe Int - , csvEUserExercisePointsMax :: Maybe Points - , csvEUserExercisePassesMax :: Maybe Int - } - deriving (Generic) - -examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } - -instance ToNamedRecord ExamUserTableCsv where - toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions - -instance FromNamedRecord ExamUserTableCsv where - parseNamedRecord = Csv.genericParseNamedRecord examUserTableCsvOptions - -instance DefaultOrdered ExamUserTableCsv where - headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions - -instance CsvColumnsExplained ExamUserTableCsv where - csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList - [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) - , ('csvEUserName , MsgCsvColumnExamUserName ) - , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) - , ('csvEUserField , MsgCsvColumnExamUserField ) - , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) - , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) - , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) - , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) - , ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses ) - , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) - , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) - ] - -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 - | 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 - } - 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 - - let - examUsersDBTable = DBTable{..} - where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do - 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) - 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) - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) - ] - 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 . _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) - 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 - 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 - , dbtCsvClassifyAction = \case - ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister - ExamUserCsvRegisterData{} -> ExamUserCsvRegister - ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister - ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence - ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField - , 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 - } - insert_ ExamRegistration - { examRegistrationExam = eid - , examRegistrationUser = examUserCsvActUser - , examRegistrationOccurrence = examUserCsvActOccurrence - , examRegistrationTime = now - } - ExamUserCsvRegisterData{..} -> do - examRegistrationTime <- liftIO getCurrentTime - insert_ ExamRegistration - { examRegistrationExam = eid - , examRegistrationUser = examUserCsvActUser - , examRegistrationOccurrence = examUserCsvActOccurrence - , .. - } - ExamUserCsvAssignOccurrenceData{..} -> - update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] - ExamUserCsvSetCourseFieldData{..} -> - update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] - ExamUserCsvDeregisterData{..} -> delete examUserCsvActRegistration - 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} - |] - 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 - ] - 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 - - 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") - - -getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEAddUserR = postEAddUserR -postEAddUserR = error "postEAddUserR" - -getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEInviteR = postEInviteR -postEInviteR = error "postEInviteR" - -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 (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Success [whamlet| -

          #{iconExamRegister True} -
            -
          _{MsgExamRegisteredSuccess examn} - |] - redirect $ CExamR tid ssh csh examn EShowR - BtnExamDeregister -> do - runDB $ do - deleteBy $ UniqueExamRegistration eId uid - audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageWidget Info [whamlet| -
          #{iconExamRegister False} -
            -
          _{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"] +module Handler.Exam + ( module Handler.Exam + ) where + +import Handler.Exam.List as Handler.Exam +import Handler.Exam.Register as Handler.Exam +import Handler.Exam.CorrectorInvite as Handler.Exam +import Handler.Exam.RegistrationInvite as Handler.Exam +import Handler.Exam.New as Handler.Exam +import Handler.Exam.Edit as Handler.Exam +import Handler.Exam.Show as Handler.Exam +import Handler.Exam.Users as Handler.Exam +import Handler.Exam.AddUser as Handler.Exam diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs new file mode 100644 index 000000000..fdc7fc3b0 --- /dev/null +++ b/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 } + + diff --git a/src/Handler/Exam/CorrectorInvite.hs b/src/Handler/Exam/CorrectorInvite.hs new file mode 100644 index 000000000..cc2882679 --- /dev/null +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs new file mode 100644 index 000000000..06abd7834 --- /dev/null +++ b/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") diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs new file mode 100644 index 000000000..1020c6f28 --- /dev/null +++ b/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 diff --git a/src/Handler/Exam/List.hs b/src/Handler/Exam/List.hs new file mode 100644 index 000000000..752d8e3c1 --- /dev/null +++ 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") diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs new file mode 100644 index 000000000..d6bcfc828 --- /dev/null +++ b/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") diff --git a/src/Handler/Exam/Register.hs b/src/Handler/Exam/Register.hs new file mode 100644 index 000000000..cc8e387a7 --- /dev/null +++ b/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"] diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs new file mode 100644 index 000000000..e9d19f338 --- /dev/null +++ b/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 diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs new file mode 100644 index 000000000..ad371d147 --- /dev/null +++ b/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| +

          + $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") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs new file mode 100644 index 000000000..ac590c7ba --- /dev/null +++ b/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") diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 7b29e2bbd..36649a436 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -70,6 +70,9 @@ getHealthR = do $of HealthWidgetMemcached (Just passed)

          _{MsgHealthWidgetMemcached}
          #{boolSymbol passed} + $of HealthActiveJobExecutors (Just active) +
          _{MsgHealthActiveJobExecutors} +
          #{textPercent active 1} $of _ |] provideJson healthReports diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 05bb6b1f2..186933caf 100644 --- a/src/Handler/Home.hs +++ b/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} } -> - msgCell $ courseTerm course - , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> - msgCell $ courseSchool course + sortable (Just "term") (i18nCell MsgTerm) + $ \DBRow{ dbrOutput=Entity{entityVal = Course{..}} } -> + anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|] + , 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) - queryExam = $(sqlIJproj 2 2) - lensCourse = _1 - lensExam = _2 + queryCourse = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) + queryExam = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) + lensCourse = _1 + 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) - E.&&. exam E.^. ExamRegisterFrom E.<=. E.just (E.val fortnight) - E.where_ $ E.isJust (exam E.^. ExamEnd) - E.&&. exam E.^. ExamEnd E.>=. E.just (E.val now) - return (course, exam) + let regToWithinFortnight = exam E.^. ExamRegisterTo E.<=. E.just (E.val fortnight) + E.&&. exam E.^. ExamRegisterTo E.>=. E.just (E.val now) + E.&&. E.isNothing (register E.?. ExamRegistrationId) + startExamFortnight = exam E.^. ExamStart E.<=. E.just (E.val fortnight) + 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 label = bool MsgExamNotRegistered MsgExamRegistered isRegistered + let isRegistered = has lensRegister dbrOutput + 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)) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 8afac65ce..5d035d293 100644 --- a/src/Handler/Profile.hs +++ b/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 - where - nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template) +notificationForm template = wFormToAForm $ do + mbUid <- liftHandlerT maybeAuthId + 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 9c182bb45..b6fc50cfa 100644 --- a/src/Handler/Sheet.hs +++ b/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 - invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName - invitationUltDest Sheet{..} _ = do + invitationForm _ (InvDBDataSheetCorrector load state, _) _ = pure $ (JunctionSheetCorrector load state, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName + invitationUltDest (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cd367b493..fa8decc7f 100644 --- a/src/Handler/Submission.hs +++ b/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 - invitationSuccessMsg Submission{..} _ = do + invitationForm _ _ _ = pure (JunctionSubmissionUser, ()) + 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 diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 64a85bfef..8d67d8e5c 100644 --- a/src/Handler/Term.hs +++ b/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." diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2f4123a22..5232dad17 100644 --- a/src/Handler/Tutorial.hs +++ b/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 - invitationSuccessMsg Tutorial{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName - invitationUltDest Tutorial{..} _ = do + invitationForm _ _ _ = pure (JunctionTutor, ()) + invitationInsertHook _ _ _ _ = id + invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName + invitationUltDest (Entity _ Tutorial{..}) _ = do Course{..} <- get404 tutorialCourse return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs new file mode 100644 index 000000000..3650755d5 --- /dev/null +++ b/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") diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 30470cf3a..59f5837c9 100644 --- a/src/Handler/Users.hs +++ b/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 $ - forM changes $ \(sid, userAdmin, userLecturer) -> + runDBJobs $ do + 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 - let form = wrapForm formWidget def + redirect $ AdminUserR uuid + + 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) - let btnForm = wrapForm btnWgt def + (deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete) + 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 diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 4bb875d02..03a9d4d77 100644 --- a/src/Handler/Utils/Csv.hs +++ b/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 = transPipe throwExceptT $ fromNamedCsv defaultDecodeOptions +decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => Conduit ByteString m csv +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 diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index f0ba27edb..8bb33a222 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -31,36 +31,9 @@ import qualified Data.Set as Set import Data.Time.Clock.System (systemEpochDay) - --------------------- --- 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 - +------------- +-- 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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 852bc1aa5..00d2ef698 100644 --- a/src/Handler/Utils/Form.hs +++ b/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. - ( Finite k, Ord k - , MonadHandler m - , HandlerSite m ~ UniWorX - ) - => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v) -funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty +sectionedFuncForm :: forall k v m sec. + ( Finite k, Ord k + , MonadHandler m + , HandlerSite m ~ UniWorX + , RenderMessage UniWorX sec + , Ord sec + ) + => (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 +
          + + $maybe optMsg' <- assertM (const $ not isReq) optMsg +