fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into course-teaser

Browse Source
This commit is contained in:
Sarah Vaupel 2019-08-06 19:14:36 +02:00
commit 9b195155c1
126 changed files with 7155 additions and 3899 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
CHANGELOG.md
View File

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

4
config/settings.yml
View File

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

2
default.nix
View File

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

11
frontend/src/utils/alerts/alerts.js
View File

@ -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);

33
frontend/src/utils/alerts/alerts.scss
View File

@ -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';
* }
*/
}

4
frontend/src/utils/form/interactive-fieldset.js
View File

@ -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!');

21
is-clean.sh Executable file
View File

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

160
messages/uniworx/de.msg
View File

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

71
models/allocations Normal file
View File

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

9
models/audit
View File

@ -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
info Value -- JSON-encoded `Transaction`

1
models/courses
View File

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

1
models/exams
View File

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

1
models/jobs
View File

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

2
models/users
View File

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

9
nixpkgs.nix Normal file
View File

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

2
package-lock.json generated
View File

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

4
package.json
View File

@ -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"
},

4
package.yaml
View File

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

12
routes
View File

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

2
shell.nix
View File

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

11
src/Application.hs
View File

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

76
src/Audit.hs
View File

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

24
src/Audit/Types.hs
View File

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

131
src/Auth/LDAP.hs
View File

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

17
src/Control/Concurrent/Async/Lifted/Safe/Utils.hs Normal file
View File

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

183
src/Cron.hs
View File

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

23
src/Cron/Types.hs
View File

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

1
src/CryptoID.hs
View File

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

6
src/Data/Fixed/Instances.hs
View File

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

15
src/Data/Scientific/Instances.hs Normal file
View File

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

25
src/Database/Esqueleto/Utils.hs
View File

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

473
src/Foundation.hs
View File

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

2
src/Handler/Admin.hs
View File

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

1648
src/Handler/Course.hs
View File

File diff suppressed because it is too large Load Diff

71
src/Handler/Course/Communication.hs Normal file
View File

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

20
src/Handler/Course/Delete.hs Normal file
View File

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

559
src/Handler/Course/Edit.hs Normal file
View File

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

86
src/Handler/Course/LecturerInvite.hs Normal file
View File

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

199
src/Handler/Course/List.hs Normal file
View File

@ -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)])

176
src/Handler/Course/ParticipantInvite.hs Normal file
View File

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

96
src/Handler/Course/Register.hs Normal file
View File

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

226
src/Handler/Course/Show.hs Normal file
View File

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

162
src/Handler/Course/User.hs Normal file
View File

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

264
src/Handler/Course/Users.hs Normal file
View File

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

1329
src/Handler/Exam.hs
View File

File diff suppressed because it is too large Load Diff

158
src/Handler/Exam/AddUser.hs Normal file
View File

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

80
src/Handler/Exam/CorrectorInvite.hs Normal file
View File

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

133
src/Handler/Exam/Edit.hs Normal file
View File

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

361
src/Handler/Exam/Form.hs Normal file
View File

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

60
src/Handler/Exam/List.hs Normal file
View File

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

93
src/Handler/Exam/New.hs Normal file
View File

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

52
src/Handler/Exam/Register.hs Normal file
View File

@ -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"]

110
src/Handler/Exam/RegistrationInvite.hs Normal file
View File

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

106
src/Handler/Exam/Show.hs Normal file
View File

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

675
src/Handler/Exam/Users.hs Normal file
View File

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

3
src/Handler/Health.hs
View File

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

67
src/Handler/Home.hs
View File

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

78
src/Handler/Profile.hs
View File

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

13
src/Handler/Sheet.hs
View File

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

17
src/Handler/Submission.hs
View File

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

2
src/Handler/Term.hs
View File

@ -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."

19
src/Handler/Tutorial.hs
View File

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

73
src/Handler/Tutorial/Users.hs Normal file
View File

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

256
src/Handler/Users.hs
View File

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

83
src/Handler/Utils/Csv.hs
View File

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

47
src/Handler/Utils/DateTime.hs
View File

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

118
src/Handler/Utils/Form.hs
View File

@ -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
<div>
<select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
<fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
^{fieldView innerField innerId name attrs innerVal False}
|]
}
examGradeField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamGrade
examGradeField = hoistField liftHandlerT $ selectField optionsFinite
examPassedField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamPassed
examPassedField = hoistField liftHandlerT $ selectField optionsFinite

88
src/Handler/Utils/Invitations.hs
View File

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

15
src/Handler/Utils/Table/Cells.hs
View File

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

6
src/Handler/Utils/Table/Pagination.hs
View File

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

19
src/Handler/Utils/Tokens.hs
View File

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

17
src/Handler/Utils/Users.hs Normal file
View File

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

12
src/Import/NoModel.hs
View File

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

423
src/Jobs.hs
View File

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

52
src/Jobs/Crontab.hs
View File

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

39
src/Jobs/Handler/QueueNotification.hs
View File

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

2
src/Jobs/Handler/SendNotification.hs
View File

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

34
src/Jobs/Handler/SendNotification/ExamResult.hs Normal file
View File

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

26
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs Normal file
View File

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

41
src/Jobs/Handler/SendPasswordReset.hs Normal file
View File

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

32
src/Jobs/Handler/TransactionLog.hs Normal file
View File

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

30
src/Jobs/HealthReport.hs
View File

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

72
src/Jobs/Queue.hs
View File

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

44
src/Jobs/Types.hs
View File

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

12
src/Language/Haskell/TH/Instances.hs
View File

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

35
src/Ldap/Client/Pool.hs
View File

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

95
src/Model/Migration.hs
View File

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

37
src/Model/Migration/Types.hs
View File

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

118
src/Model/Types/Exam.hs
View File

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

6
src/Model/Types/Health.hs
View File

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

6
src/Model/Types/Mail.hs
View File

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

5
src/Model/Types/Security.hs
View File

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

8
src/Model/Types/Sheet.hs
View File

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

6
src/Settings.hs
View File

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

8
src/Text/Blaze/Instances.hs
View File

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

126
src/Utils.hs
View File

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

19
src/Utils/Csv.hs Normal file
View File

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

14
src/Utils/DB.hs
View File

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

21
src/Utils/DateTime.hs
View File

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

87
src/Utils/Form.hs
View File

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

Some files were not shown because too many files have changed in this diff Show More