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

Merge branch 'master' into 298-alerts-sind-unlesbar

Browse Source
This commit is contained in:
Gregor Kleen 2019-05-06 18:31:09 +02:00
commit a10f79bcc4
250 changed files with 9144 additions and 2704 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
ChangeLog.md
View File

@ -1,3 +1,19 @@
* Version 04.05.2019
Kursmaterial
* Version 29.04.2019
Tutorien
Anzeige von Korrektoren auf den Kursseiten
* Version 20.04.2019
Versand von Benachrichtigungen an Kursteilnehmer
Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account
* Version 27.03.2019
Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen

6
assets/lmu/logo.svg Normal file
View File

@ -0,0 +1,6 @@
<svg width="80" height="80" viewBox="0 0 80 80" fill="none" xmlns="http://www.w3.org/2000/svg">
<rect x="0" y="0" width="80" height="80" fill="white" stroke="currentColor" stroke-width="2" />
<path d="M6.28906 73.7111V46.4124H8.85405V71.6958H16.7322V73.7111H6.28906Z" fill="currentColor" />
<path d="M19.4804 73.7111V46.4124H28.0914L32.0305 67.8483H32.5801L36.6108 46.4124H45.3135V73.7111H40.0003V50.443H39.5422L34.8703 73.7111H29.5571L24.7936 50.443H24.2439V73.7111H19.4804Z" fill="currentColor" />
<path d="M48.7945 64.0008V46.4124H58.0468V65.0085C58.0468 66.9322 59.6452 67.872 61.3446 67.8483C63.0171 67.8249 64.5508 66.749 64.5508 65.0085V46.4124H73.8031V64.0008C73.8031 66.1078 73.6565 74.2412 61.3446 74.3523C49.0327 74.4635 48.7945 66.0161 48.7945 64.0008Z" fill="currentColor" />
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 804 B

19
assets/lmu/sigillum.svg Normal file
View File

File diff suppressed because one or more lines are too long
Side by Side

After

Width:  |  Height:  |  Size: 98 KiB

4
assets/logo-o2.svg
View File

@ -1,4 +0,0 @@
<svg width="158" height="158" viewBox="0 0 158 158" fill="none" xmlns="http://www.w3.org/2000/svg">
<path fill-rule="evenodd" clip-rule="evenodd" d="M31 16.2494C12.1534 30.6875 0 53.4245 0 79C0 122.63 35.3695 158 79 158C122.63 158 158 122.63 158 79C158 53.4245 145.847 30.6875 127 16.2494V39.7542C135.75 50.4433 141 64.1086 141 79C141 113.242 113.242 141 79 141C44.7583 141 17 113.242 17 79C17 64.1086 22.25 50.4433 31 39.7542V16.2494Z" fill="#0A9342"/>
<path d="M119.111 121H40.5371V107.597L79.4631 65.1392C85.0813 58.879 89.0675 53.6621 91.4218 49.4886C93.8296 45.2616 95.0335 41.0345 95.0335 36.8075C95.0335 31.2429 93.4551 26.7483 90.2982 23.3239C87.1948 19.8995 82.9945 18.1873 77.6974 18.1873C71.3836 18.1873 66.4878 20.1135 63.0099 23.966C59.5319 27.8184 57.793 33.0888 57.793 39.7771H38.2899C38.2899 32.6608 39.8951 26.2668 43.1055 20.5951C46.3693 14.8699 50.9977 10.4288 56.9904 7.27195C63.0366 4.11506 69.9925 2.53662 77.8579 2.53662C89.2013 2.53662 98.1369 5.39922 104.665 11.1244C111.246 16.7961 114.537 24.6616 114.537 34.7208C114.537 40.553 112.878 46.6795 109.561 53.1003C106.297 59.4675 100.919 66.7177 93.4283 74.8506L64.8558 105.43H119.111V121Z" fill="#0A9342"/>
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 1.2 KiB

BIN
assets/logo.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 6.5 KiB

2
build.sh
View File

@ -1,4 +1,4 @@
#!/usr/bin/env bash
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev
exec -- stack build --fast --flag uniworx:-library-only --flag uniworx:dev $@
echo Build task completed.

5
config/settings.yml
View File

@ -27,7 +27,12 @@ notification-rate-limit: 3600
notification-collate-delay: 300
notification-expiration: 259201
session-timeout: 7200
jwt-expiration: 604800
jwt-encoding: HS256
maximum-content-length: 52428800
health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller
health-check-http: "_env:HEALTHCHECK_HTTP:true"
health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
log-settings:
detailed: "_env:DETAILED_LOGGING:false"

4
db.sh
View File

@ -1,4 +1,6 @@
#!/usr/bin/env bash
# Options: see /test/Database.hs (Main)
stack build --fast --flag uniworx:library-only --flag uniworx:dev
set -e
stack build --fast --flag uniworx:-library-only --flag uniworx:dev
stack exec uniworxdb -- $@

13
haddock.sh
View File

@ -1,3 +1,14 @@
#!/usr/bin/env bash
exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal
move-back() {
mv -v .stack-work .stack-work-doc
[[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
}
if [[ -d .stack-work-doc ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-doc .stack-work
trap move-back EXIT
fi
stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal

3
hlint.sh Executable file
View File

@ -0,0 +1,3 @@
#!/usr/bin/env bash
exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint

4
messages/frontend/de.msg Normal file
View File

@ -0,0 +1,4 @@
FilesSelected: Dateien ausgewählt
SelectFile: Datei auswählen
SelectFiles: Datei(en) auswählen
AsyncFormFailure: Da ist etwas schief gelaufen, das tut uns Leid. Falls das erneut passiert schicke uns gerne eine kurze Beschreibung dieses Ereignisses über das Hilfe-Widget rechts oben. Vielen Dank für deine Hilfe!

263
messages/uniworx/de.msg
View File

@ -10,6 +10,11 @@ BtnSave: Speichern
BtnCandidatesInfer: Studienfachzuordnung automatisch lernen
BtnCandidatesDeleteConflicts: Konflikte löschen
BtnCandidatesDeleteAll: Alle Beobachtungen löschen
BtnResetTokens: Authorisierungs-Tokens invalidieren
BtnLecInvAccept: Annehmen
BtnLecInvDecline: Ablehnen
BtnCorrInvAccept: Annehmen
BtnCorrInvDecline: Ablehnen
Aborted: Abgebrochen
Remarks: Hinweise
@ -19,6 +24,7 @@ RegisteredSince date@Text: Angemeldet seit #{date}
RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
RegisterRetry: Sie wurden noch nicht angemeldet. Drücken Sie dazu den Knopf "Anmelden"
GenericKey: Schlüssel
GenericShort: Kürzel
@ -64,10 +70,12 @@ CourseShort: Kürzel
CourseCapacity: Kapazität
CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
TutorialNoCapacity: In dieser Übung sind keine Plätze mehr frei.
CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
CourseRegisterOk: Anmeldung erfolgreich
CourseDeregisterOk: Erfolgreich abgemeldet
CourseStudyFeature: Assoziiertes Hauptfach
CourseTutorial: Tutorium
CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort
@ -114,6 +122,10 @@ CourseUserNoteSaved: Notizänderungen gespeichert
CourseUserNoteDeleted: Teilnehmernotiz gelöscht
CourseUserDeregister: Abmelden
CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
CourseUserSendMail: Mitteilung verschicken
TutorialUserDeregister: Vom Tutorium Abmelden
TutorialUserSendMail: Mitteilung verschicken
TutorialUsersDeregistered count@Int64: #{show count} Tutorium-Teilnehmer abgemeldet
CourseLecturers: Kursverwalter
CourseLecturer: Dozent
@ -122,7 +134,7 @@ 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
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
@ -136,8 +148,8 @@ SheetNewOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetNa
SheetTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
SheetEditOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wurde gespeichert in Kurs #{display tid}-#{display ssh}-#{csh}
SheetNameDup tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
@ -159,21 +171,21 @@ SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan
SheetName: Name
SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
SheetVisibleFrom: Sichtbar ab
SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
SheetActiveFrom: Aktiv ab
SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
SheetActiveTo: Abgabefrist
SheetVisibleFrom: Sichtbar für Teilnehmer ab
SheetVisibleFromTip: Ohne Datum nie sichtbar und keine Abgabe möglich; nur für unfertige Blätter leer lassen, deren Bewertung/Fristen sich noch ändern können
SheetActiveFrom: Beginn Abgabezeitraum
SheetActiveFromTip: Download der Aufgabenstellung erst ab diesem Datum möglich
SheetActiveTo: Ende Abgabezeitraum
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
SheetPseudonym: Persönliches Abgabe-Pseudonym
SheetGeneratePseudonym: Generieren
SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden
SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden
SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
Deadline: Abgabe
@ -202,10 +214,40 @@ CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen
MaterialName: Name
MaterialType: Art
MaterialTypePlaceholder: Folien, Code, Beispiel, ...
MaterialTypeSlides: Folien
MaterialTypeCode: Code
MaterialTypeExample: Beispiel
MaterialDescription: Beschreibung
MaterialVisibleFrom: Sichtbar für Teilnehmer ab
MaterialVisibleFromTip: Ohne Datum nie sichtbar für Teilnehmer; leer lassen ist nur sinnvoll für unfertige Materialien oder zur ausschließlichen Verteilung an Korrektoren
MaterialInvisible: Dieses Material ist für Teilnehmer momentan unsichtbar!
MaterialInvisibleUntil date@Text: Dieses Material ist für Teilnehmer momentan unsichtbar bis #{date}!
MaterialFiles: Dateien
MaterialHeading materialName@MaterialName: Material "#{materialName}"
MaterialListHeading: Materialien
MaterialNewHeading: Neues Material veröffentlichen
MaterialNewTitle: Neues Material
MaterialEditHeading materialName@MaterialName: Material "#{materialName}" editieren
MaterialEditTitle materialName@MaterialName: Material "#{materialName}" editieren
MaterialSaveOk tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Material "#{materialName}" erfolgreich gespeichert in Kurs #{display tid}-#{display ssh}-#{csh}
MaterialNameDup tid@TermId ssh@SchoolId csh@CourseShorthand materialName@MaterialName: Es gibt bereits Material mit Namen "#{materialName}" in diesem Kurs #{display tid}-#{display ssh}-#{csh}
MaterialDeleteQuestion: Wollen Sie das unten aufgeführte Material wirklich löschen?
MaterialDeleted materialName@MaterialName: Material "#{materialName}" gelöscht
Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt.
UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen.
UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig.
UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden.
UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig.
UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
@ -218,6 +260,8 @@ UnauthorizedRegistered: Sie sind nicht als Teilnehmer für diese Veranstaltung r
UnauthorizedParticipant: Angegebener Benutzer ist nicht als Teilnehmer dieser Veranstaltung registriert.
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben.
UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
@ -234,6 +278,11 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au
UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv
UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt
UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen.
UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer.
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.
EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -241,10 +290,10 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic
TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
CorrectorExists: Nutzer ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen
Corrector: Korrektor
Correctors: Korrektoren
CorState: Status
@ -254,8 +303,8 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile
CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt
DeleteRow: Zeile entfernen
RowCount count@Int64: #{display count} #{pluralDE count "passender Eintrag" "passende Einträge"} insgesamt
DeleteRow: Entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorUpdated: Korrektor erfolgreich aktualisiert
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
@ -275,6 +324,9 @@ ImpressumHeading: Impressum
DataProtHeading: Datenschutzerklärung
SystemMessageHeading: Uni2work Statusmeldung
SystemMessageListHeading: Uni2work Statusmeldungen
NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName}
TokensLastReset: Tokens zuletzt invalidiert
TokensResetSuccess: Authorisierungs-Tokens invalidiert
HomeOpenCourses: Kurse mit offener Registrierung
HomeUpcomingSheets: Anstehende Übungsblätter
@ -291,10 +343,14 @@ Plugin: Plugin
Ident: Identifikation
LastLogin: Letzter Login
Settings: Individuelle Benutzereinstellungen
SettingsUpdate: Einstellungen wurden gespeichert.
SettingsUpdate: Einstellungen erfolgreich gespeichert
NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert
Never: Nie
PreviouslyUploadedInfo: Bereits hochgeladene Dateien:
PreviouslyUploadedDeletionInfo: (Nicht ausgewählte Dateien werden gelöscht)
MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
AddMoreFiles: Weitere Dateien hinzufügen:
NrColumn: Nr
SelectColumn: Auswahl
@ -350,6 +406,8 @@ Pseudonyms: Pseudonyme
FileTitle: Dateiname
FileModified: Letzte Änderung
VisibleFrom: Veröffentlicht
AccessibleSince: Verfügbar seit
Corrected: Korrigiert
@ -387,6 +445,8 @@ LecturerFor: Dozent
LecturersFor: Dozenten
AssistantFor: Assistent
AssistantsFor: Assistenten
TutorsFor n@Int: #{pluralDE n "Tutor" "Tutoren"}
CorrectorsFor n@Int: #{pluralDE n "Korrektor" "Korrektoren"}
ForSchools n@Int: für #{pluralDE n "Institut" "Institute"}
UserListTitle: Komprehensive Benutzerliste
AccessRightsSaved: Berechtigungsänderungen wurden gespeichert.
@ -421,6 +481,7 @@ LDAPLoginTitle: Campus-Login
PWHashLoginTitle: Uni2work-Login
PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an!
DummyLoginTitle: Development-Login
LoginNecessary: Bitte melden Sie sich dazu vorher an!
CorrectorNormal: Normal
CorrectorMissing: Abwesend
@ -435,9 +496,10 @@ UploadModeNone: Kein Upload
UploadModeUnpack: Upload, einzelne Datei
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
SheetNoSubmissions: Keine Abgabe
SheetCorrectorSubmissions: Abgabe extern mit Pseudonym
SheetUserSubmissions: Direkte Abgabe
NoSubmissions: Keine Abgabe
CorrectorSubmissions: Abgabe extern mit Pseudonym
UserSubmissions: Direkte Abgabe
BothSubmissions: Abgabe direkt & extern mit Pseudonym
SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können.
@ -496,7 +558,7 @@ MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@She
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfrist für #{sheetName} in #{csh} abgelaufen
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabezeitraum für #{sheetName} in #{csh} abgelaufen
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName n@Int num@Int64: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet. Es gab #{noneOneMoreDE n "Keine Abgaben" "Nur eine Abgabe von " (display n <> " Abgaben von ")}#{noneOneMoreDE num "" "einem Teilnehmer" (display num <> " Teilnehmern")}.
MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
@ -510,6 +572,15 @@ MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{plu
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject}
CommCourseSubject: Kursmitteilung
MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter
InvitationAcceptDecline: Einladung annehmen/ablehnen
MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn}
MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn}
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
@ -548,12 +619,13 @@ SheetGroupNoGroups: Keine Gruppenabgabe
SheetGroupMaxGroupsize: Maximale Gruppengröße
SheetFiles: Übungsblatt-Dateien
SheetFileTypeHeader: Zugehörigkeit
NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter ist abgelaufen
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
@ -584,6 +656,7 @@ HelpAnswer: Antworten an
HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym)
HelpEmail: E-Mail
HelpSubject: Betreff
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
@ -658,15 +731,19 @@ MenuInformation: Informationen
MenuImpressum: Impressum
MenuDataProt: Datenschutz
MenuVersion: Versionsgeschichte
MenuInstance: Instanz-Identifikation
MenuHealth: Instanz-Zustand
MenuHelp: Hilfe
MenuProfile: Anpassen
MenuLogin: Login
MenuLogout: Logout
MenuCourseList: Kurse
MenuCourseMembers: Kursteilnehmer
MenuCourseCommunication: Kursmitteilung
MenuTermShow: Semester
MenuSubmissionDelete: Abgabe löschen
MenuUsers: Benutzer
MenuUserNotifications: Benachrichtigungs-Einstellungen
MenuAdminTest: Admin-Demo
MenuMessageList: Systemnachrichten
MenuAdminErrMsg: Fehlermeldung entschlüsseln
@ -679,6 +756,12 @@ MenuCorrections: Korrekturen
MenuCorrectionsOwn: Meine Korrekturen
MenuSubmissions: Abgaben
MenuSheetList: Übungsblätter
MenuMaterialList: Material
MenuMaterialNew: Neues Material veröffentlichen
MenuMaterialEdit: Material bearbeiten
MenuMaterialDelete: Material löschen
MenuTutorialList: Tutorien
MenuTutorialNew: Neues Tutorium anlegen
MenuSheetNew: Neues Übungsblatt anlegen
MenuSheetCurrent: Aktuelles Übungsblatt
MenuSheetOldUnassigned: Abgaben ohne Korrektor
@ -695,20 +778,26 @@ MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten
MenuAuthPreds: Authorisierungseinstellungen
MenuTutorialDelete: Tutorium löschen
MenuTutorialEdit: Tutorium editieren
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
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
AuthTagFree: Seite ist universell zugänglich
AuthTagAdmin: Nutzer ist Administrator
AuthTagToken: Nutzer präsentiert Authorisierungs-Token
AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet
AuthTagDeprecated: Seite ist nicht überholt
AuthTagDevelopment: Seite ist nicht in Entwicklung
AuthTagLecturer: Nutzer ist Dozent
AuthTagCorrector: Nutzer ist Korrektor
AuthTagTutor: Nutzer ist Tutor
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
AuthTagRegistered: Nutzer ist Kursteilnehmer
AuthTagCourseRegistered: Nutzer ist Kursteilnehmer
AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer
AuthTagParticipant: Nutzer ist mit Kurs assoziiert
AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe
AuthTagCapacity: Kapazität ist ausreichend
AuthTagEmpty: Kurs hat keine Teilnehmer
AuthTagMaterials: Kursmaterialien sind freigegeben
@ -716,6 +805,7 @@ AuthTagOwner: Nutzer ist Besitzer
AuthTagRated: Korrektur ist bewertet
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
AuthTagSelf: Nutzer greift nur auf eigene Daten zu
AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend
@ -724,9 +814,128 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "
DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
MassInputAddDimension: Hinzufügen
MassInputDeleteCell: Entfernen
MassInputAddDimension: +
MassInputDeleteCell: -
NavigationFavourites: Favoriten
NavigationFavourites: Favoriten
CommSubject: Betreff
CommBody: Nachricht
CommRecipients: Empfänger
CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht
CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert
CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt
CommCourseHeading: Kursmitteilung
CommTutorialHeading: Tutorium-Mitteilung
RecipientCustom: Weitere Empfänger
RecipientToggleAll: Alle/Keine
RGCourseParticipants: Kursteilnehmer
RGCourseLecturers: Kursverwalter
RGCourseCorrectors: Korrektoren
RGCourseTutors: Tutoren
RGTutorialParticipants: Tutorium-Teilnehmer
MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg)
MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich
EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt.
LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen
LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt
CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName}
CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein.
CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen
CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt
SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn}
SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein.
TutorInvitationAccepted tutn@TutorialName: Sie wurden als Tutor für #{tutn} eingetragen
TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für #{tutn} zu werden, abgelehnt
TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn}
TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein.
InvitationAction: Aktion
InvitationActionTip: Abgelehnte Einladungen können nicht mehr angenommen werden
InvitationMissingRestrictions: Authorisierungs-Token fehlen benötigte Daten
InvitationCollision: Einladung konnte nicht angenommen werden da ein derartiger Eintrag bereits existiert
InvitationDeclined: Einladung wurde abgelehnt
BtnInviteAccept: Einladung annehmen
BtnInviteDecline: Einladung ablehnen
LecturerType: Rolle
ScheduleKindWeekly: Wöchentlich
ScheduleRegular: Planmäßiger Termin
ScheduleRegularKind: Plan
WeekDay: Wochentag
Day: Tag
OccurenceStart: Beginn
OccurenceEnd: Ende
ScheduleExists: Dieser Plan existiert bereits
ScheduleExceptions: Termin-Ausnahmen
ScheduleExceptionsTip: Ausfälle überschreiben planmäßiges Stattfinden. Außerplanmäßiges Stattfinden überschreibt Ausfall.
ExceptionKind: Termin ...
ExceptionKindOccur: Findet statt
ExceptionKindNoOccur: Findet nicht statt
ExceptionExists: Diese Ausnahme existiert bereits
ExceptionNoOccurAt: Termin
TutorialType: Typ
TutorialName: Bezeichnung
TutorialParticipants: Teilnehmer
TutorialCapacity: Kapazität
TutorialFreeCapacity: Freie Plätze
TutorialRoom: Regulärer Raum
TutorialTime: Zeit
TutorialRegistered: Angemeldet
TutorialRegGroup: Registrierungs-Gruppe
TutorialRegisterFrom: Anmeldungen ab
TutorialRegisterTo: Anmeldungen bis
TutorialDeregisterUntil: Abmeldungen bis
TutorialsHeading: Tutorien
TutorialEdit: Bearbeiten
TutorialDelete: Löschen
CourseTutorials: Übungen
ParticipantsN n@Int: Teilnehmer
TutorialDeleteQuestion: Wollen Sie das unten aufgeführte Tutorium wirklich löschen?
TutorialDeleted: Tutorium gelöscht
TutorialRegisteredSuccess tutn@TutorialName: Erfolgreich zum Tutorium #{tutn} angemeldet
TutorialDeregisteredSuccess tutn@TutorialName: Erfolgreich vom Tutorium #{tutn} abgemeldet
TutorialNameTip: Muss eindeutig sein
TutorialCapacityNonPositive: Kapazität muss größer oder gleich null sein
TutorialCapacityTip: Beschränkt wieviele Studenten sich zu diesem Tutorium anmelden können
TutorialRegGroupTip: Studenten können sich in jeweils maximal einem Tutorium pro Registrierungs-Gruppe anmelden. Ist bei zwei oder mehr Tutorien keine Registrierungs-Gruppe gesetzt zählen diese als in verschiedenen Registrierungs-Gruppen
TutorialRoomPlaceholder: Raum
TutorialTutors: Tutoren
TutorialTutorAlreadyAdded: Ein Tutor mit dieser E-Mail ist bereits für dieses Tutorium eingetragen
TutorialNew: Neues Tutorium
TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn}
TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt
TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten
MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Die Liste wird zunächst nur lokal in Ihrem Browser gespeichert und muss noch zusammen mit dem Rest des Formulars Gesendet werden.
HealthReport: Instanz-Zustand
InstanceIdentification: Instanz-Identifikation
InstanceId: Instanz-Nummer
ClusterId: Cluster-Nummer
HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell
HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden
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

5
models/invitations Normal file
View File

@ -0,0 +1,5 @@
Invitation
email UserEmail
for Value
data Value
UniqueInvitation email for

12
models/materials Normal file
View File

@ -0,0 +1,12 @@
Material -- course material for disemination to course participants
course CourseId
name (CI Text)
type Text Maybe
description Html Maybe
visibleFrom UTCTime Maybe -- Invisible to enrolled participants before
lastEdit UTCTime
UniqueMaterial course name
deriving Generic
MaterialFile -- a file that is part of a material distribution
material MaterialId
file FileId

32
models/rooms
View File

@ -1,32 +0,0 @@
-- ROOMS ARE TODO; THIS IS JUST AN UNUSED STUB
-- Idea is to create a selection of rooms that may be
-- associated with exercise classes and exams
-- offering links to the LMU Roomfinder
-- and allow the creation of neat timetables for users
Booking
term TermId
begin UTCTime
end UTCTime
weekly Bool
exceptions [Day] -- only if weekly, begin in exception
bookedFor RoomForId
room RoomId
BookingEdit
user UserId
time UTCTime
boooking BookingId
Room
name Text
capacity Int Maybe
building Text Maybe -- name of building
roomfinder Text Maybe -- external url for LMU Roomfinder
-- BookingRoom
-- subject RoomForId
-- room RoomId
-- booking BookingId
-- UniqueRoomCourse subject room booking
+RoomFor
course CourseId
tutorial TutorialId
exam ExamId
-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...

3
models/sheets
View File

@ -10,8 +10,7 @@ Sheet -- exercise sheet for a given course
activeTo UTCTime -- Submission is only permitted before
hintFrom UTCTime Maybe -- Additional files are made available
solutionFrom UTCTime Maybe -- Solution is made available
uploadMode UploadMode -- Take apart Zip-Archives or not?
submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only?
submissionMode SubmissionMode -- Submission upload by students and/or through tutors?
autoDistribute Bool default=false -- Should correctors be assigned submissions automagically?
CourseSheet course name
deriving Generic

28
models/tutorials
View File

@ -1,11 +1,21 @@
-- TUTORIALS ARE TODO; THIS IS JUST AN UNUSED STUB
-- Idea: management of exercise classes, offering sub-enrolement to distribute all students among all exercise classs
Tutorial json
name Text
tutor UserId
course CourseId
capacity Int Maybe -- limit for enrolement in this tutorial
TutorialUser
user UserId
name TutorialName
course CourseId
type (CI Text) -- "Tutorium", "Zentralübung", ...
capacity Int Maybe -- limit for enrolment in this tutorial
room Text
time Occurences
regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup
registerFrom UTCTime Maybe
registerTo UTCTime Maybe
deregisterUntil UTCTime Maybe
lastChanged UTCTime default='NOW()'
UniqueTutorial course name
Tutor
tutorial TutorialId
UniqueTutorialUser user tutorial
user UserId
UniqueTutor tutorial user
TutorialParticipant
tutorial TutorialId
user UserId
UniqueTutorialParticipant tutorial user

1
models/users
View File

@ -11,6 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create
ident (CI Text) -- Case-insensitive user-identifier
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
lastAuthentication UTCTime Maybe -- last login date
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
email (CI Text) -- Case-insensitive eMail address
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)

14
package.yaml
View File

@ -85,6 +85,7 @@ dependencies:
- scientific
- tz
- system-locale
- th-lift
- th-lift-instances
- gitrev
- Glob
@ -117,6 +118,14 @@ dependencies:
- lattices
- hsass
- semigroupoids
- jose-jwt
- mono-traversable
- lens-aeson
- systemd
- lifted-async
- streaming-commons
- hourglass
- unix
other-extensions:
- GeneralizedNewtypeDeriving
@ -168,12 +177,14 @@ default-extensions:
- PackageImports
- TypeApplications
- RecursiveDo
- TypeFamilyDependencies
ghc-options:
- -Wall
- -fno-warn-type-defaults
- -fno-warn-unrecognised-pragmas
- -fno-warn-partial-type-signatures
- -fno-max-relevant-binds
when:
- condition: flag(pedantic)
@ -218,6 +229,9 @@ executables:
dependencies:
- uniworx
other-modules: []
when:
- condition: flag(library-only)
buildable: false
# Test suite
tests:

143
routes
View File

@ -13,9 +13,14 @@
-- !free -- free for all
-- !lecturer -- lecturer for this course (or for any school, if route is not connected to a course)
-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
-- !registered -- participant for this course (no effect outside of courses)
-- !course-registered -- participant for this course (no effect outside of courses)
-- !tutorial-registered -- participant for this tutorial (no effect outside of courses)
-- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses)
--
-- !register-group -- user is member in no other tutorial with same register group
--
-- !owner -- part of the group of owners of this submission
-- !self -- route refers to the currently logged in user themselves
-- !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
--
@ -34,73 +39,95 @@
/favicon.ico FaviconR GET !free
/robots.txt RobotsR GET !free
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/admin AdminR GET
/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST
/ HomeR GET !free
/users UsersR GET -- no tags, i.e. admins only
/users/#CryptoUUIDUser AdminUserR GET POST
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/admin AdminR GET
/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST
/admin/errMsg AdminErrMsgR GET POST
/info InfoR GET !free
/info/lecturer InfoLecturerR GET !lecturer
/info/data DataProtR GET !free
/impressum ImpressumR GET !free
/version VersionR GET !free
/health HealthR GET !free
/instance InstanceR GET !free
/info InfoR GET !free
/info/lecturer InfoLecturerR GET !lecturer
/info/data DataProtR GET !free
/impressum ImpressumR GET !free
/version VersionR GET !free
/help HelpR GET POST !free
/help HelpR GET POST !free
/user ProfileR GET POST !free
/user/profile ProfileDataR GET !free
/user/authpreds AuthPredsR GET POST !free
/user ProfileR GET POST !free
/user/profile ProfileDataR GET !free
/user/authpreds AuthPredsR GET POST !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
/term/edit TermEditR GET POST
/term/#TermId/edit TermEditExistR GET POST
!/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/term TermShowR GET !free
/term/current TermCurrentR GET !free
/term/edit TermEditR GET POST
/term/#TermId/edit TermEditExistR GET POST
!/term/#TermId TermCourseListR GET !free
!/term/#TermId/#SchoolId TermSchoolCourseListR GET !free
/school SchoolListR GET !development
/school/#SchoolId SchoolShowR GET !development
/school SchoolListR GET !development
/school/#SchoolId SchoolShowR GET !development
-- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free
/register CRegisterR POST !timeANDcapacity
/edit CEditR GET POST
/delete CDeleteR GET POST !lecturerANDempty
/users CUsersR GET POST
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET
/notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials !corrector
/ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !registered !materials !corrector
/ex/unassigned SheetOldUnassigned GET
/course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free
/register CRegisterR GET POST !timeANDcapacity
/edit CEditR GET POST
/lecturer-invite CLecInviteR GET POST
/delete CDeleteR GET POST !lecturerANDempty
/users CUsersR GET POST
/users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant
/correctors CHiWisR GET
/communication CCommR GET POST
/notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST
/ex SheetListR GET !course-registered !materials !corrector
/ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !course-registered !materials !corrector
/ex/unassigned SheetOldUnassigned GET
/ex/#SheetName SheetR:
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
!/subs/own SubmissionOwnR GET !free -- just redirect
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
!/subs/own SubmissionOwnR GET !free -- just redirect
/subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
/delete SubDelR GET POST !ownerANDtime
/assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
/delete SubDelR GET POST !ownerANDtime
/assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector
/file MaterialListR GET !course-registered !materials !corrector !tutor
/file/new MaterialNewR GET POST
/file/#MaterialName MaterialR:
/edit MEditR GET POST
/delete MDelR GET POST
/show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
/tuts CTutorialListR GET !tutor
/tuts/new CTutorialNewR GET POST
/tuts/#TutorialName TutorialR:
/edit TEditR GET POST
/delete TDeleteR GET POST
/participants TUsersR GET POST !tutor
/register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered
/communication TCommR GET POST !tutor
/tutor-invite TInviteR GET POST
/subs CorrectionsR GET POST !corrector !lecturer

166
src/Application.hs
View File

@ -1,7 +1,7 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev, getAppDevSettings
( getAppDevSettings
, appMain
, develMain
, makeFoundation
@ -24,8 +24,10 @@ import Language.Haskell.TH.Syntax (qLocation)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
runSettingsSocket, setHost,
setBeforeMainLoop,
setOnException, setPort, getPort)
import Data.Streaming.Network (bindPortTCP)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
@ -62,7 +64,7 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
import qualified Data.HashMap.Strict as HashMap
import Control.Lens
import Utils.Lens
import Data.Proxy
@ -71,7 +73,14 @@ import qualified Data.Aeson as Aeson
import System.Exit (exitFailure)
import qualified Database.Memcached.Binary.IO as Memcached
import qualified System.Systemd.Daemon as Systemd
import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
import System.Environment (lookupEnv)
import System.Posix.Process (getProcessID)
import Control.Monad.Trans.State (execStateT)
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.Common
@ -86,9 +95,12 @@ import Handler.School
import Handler.Course
import Handler.Sheet
import Handler.Submission
import Handler.Tutorial
import Handler.Corrections
import Handler.Material
import Handler.CryptoIDDispatch
import Handler.SystemMessage
import Handler.Health
-- This line actually creates our YesodDispatch instance. It is the second half
@ -101,7 +113,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings@AppSettings{..} = do
makeFoundation appSettings'@AppSettings{..} = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- newManager
@ -135,13 +147,14 @@ makeFoundation appSettings@AppSettings{..} = do
appJobCtl <- liftIO $ newTVarIO Map.empty
appCronThread <- liftIO newEmptyTMVarIO
appHealthReport <- liftIO $ newTVarIO Nothing
-- We need a log function to create a connection pool. We need a connection
-- pool to create our foundation. And we need our foundation to get a
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID = UniWorX {..}
-- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@ -153,38 +166,54 @@ makeFoundation appSettings@AppSettings{..} = do
(error "sessionKey forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation")
(error "widgetMemcached forced in tempFoundation")
logFunc loc src lvl str = do
f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger)
f loc src lvl str
(error "JSONWebKeySet forced in tempFoundation")
(error "ClusterID forced in tempFoundation")
flip runLoggingT logFunc $ do
$logDebugS "InstanceID" $ UUID.toText appInstanceID
-- logDebugS "Configuration" $ tshow appSettings
runAppLoggingT tempFoundation $ do
$logInfoS "InstanceID" $ UUID.toText appInstanceID
-- logDebugS "Configuration" $ tshow appSettings'
smtpPool <- traverse createSmtpPool appSmtpConf
smtpPool <- for appSmtpConf $ \c -> do
$logDebugS "setup" "SMTP-Pool"
createSmtpPool c
appWidgetMemcached <- traverse createWidgetMemcached appWidgetMemcachedConf
appWidgetMemcached <- for appWidgetMemcachedConf $ \c -> do
$logDebugS "setup" "Widget-Memcached"
createWidgetMemcached c
-- Create the database connection pool
$logDebugS "setup" "PostgreSQL-Pool"
sqlPool <- createPostgresqlPool
(pgConnStr appDatabaseConf)
(pgPoolSize appDatabaseConf)
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
ldapPool <- for appLdapConf $ \LdapConf{..} -> do
$logDebugS "setup" "LDAP-Pool"
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
-- Perform database migration using our application's logging settings.
$logDebugS "setup" "Migration"
migrateAll `runSqlPool` sqlPool
$logDebugS "setup" "Cluster-Config"
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
handleJobs foundation
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID
-- Return the foundation
$logDebugS "setup" "Done"
return foundation
runAppLoggingT :: UniWorX -> LoggingT m a -> m a
runAppLoggingT app@(appLogger -> (_, loggerTVar)) = flip runLoggingT logFunc
where
logFunc loc src lvl str = do
f <- messageLoggerSource app <$> readTVarIO loggerTVar
f loc src lvl str
clusterSetting :: forall key m p.
( MonadIO m
, ClusterSetting key
@ -203,7 +232,7 @@ clusterSetting proxy@(knownClusterSetting -> key) = do
new <- initClusterSetting proxy
void . insert $ ClusterConfig key (Aeson.toJSON new)
return new
readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
where
@ -224,7 +253,7 @@ createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
let
withLogging :: LoggingT IO a -> IO a
withLogging = flip runLoggingT logFunc
mkConnection = withLogging $ do
$logInfoS "SMTP" "Opening new connection"
liftIO mkConnection'
@ -265,7 +294,7 @@ makeLogWare app = do
logger <- readTVarIO . snd $ appLogger app
logWare <- mkRequestLogger def
{ outputFormat = bool
(Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
(Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader)
(Detailed True)
logDetailed
, destination = Logger $ loggerSet logger
@ -287,8 +316,20 @@ makeLogWare app = do
-- | Warp settings for the given foundation value.
warpSettings :: UniWorX -> Settings
warpSettings foundation = defaultSettings
& setPort (appPort $ appSettings foundation)
& setHost (appHost $ appSettings foundation)
& setBeforeMainLoop (runAppLoggingT foundation $ do
let notifyReady = do
$logInfoS "setup" "Ready"
void $ liftIO Systemd.notifyReady
if
| foundation ^. _appHealthCheckDelayNotify
-> void . fork $ do
atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd)
notifyReady
| otherwise
-> notifyReady
)
& setHost (foundation ^. _appHost)
& setPort (foundation ^. _appPort)
& setOnException (\_req e ->
when (defaultShouldDisplayException e) $ do
logger <- readTVarIO . snd $ appLogger foundation
@ -300,43 +341,65 @@ warpSettings foundation = defaultSettings
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
getApplicationDev = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv
getAppDevSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
adjustSettings :: MonadIO m => AppSettings -> m AppSettings
adjustSettings = execStateT $ do
watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
myProcessID <- liftIO getProcessID
case watchdogMicroSec of
Just wInterval
| maybe True (== myProcessID) watchdogProcess
-> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
_other -> return ()
-- | main function for use by yesod devel
develMain :: IO ()
develMain = runResourceT $
liftIO . develMainHelper . return =<< getApplicationDev
develMain = runResourceT $ do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation
handleJobs foundation
liftIO . develMainHelper $ return (wsettings, app)
-- | The @main@ function for an executable running this site.
appMain :: MonadResourceBase m => m ()
appMain = runResourceT $ do
-- Get the settings from all relevant sources
settings <- liftIO $
loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
settings <- getAppSettings
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
runAppLoggingT foundation $ do
$logDebugS "setup" "Job-Handling"
handleJobs foundation
-- Run the application with Warp
liftIO $ runSettings (warpSettings foundation) app
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
activatedSockets <- liftIO Systemd.getActivatedSocketsWithNames
sockets <- case activatedSockets of
Just socks@(_ : _) -> do
$logInfoS "bind" [st|Ignoring configuration and listening on #{tshow (fmap snd socks)}|]
return $ fst <$> socks
_other -> do
let
host = foundation ^. _appHost
port = foundation ^. _appPort
$logInfoS "bind" [st|Listening on #{tshow host} port #{tshow port} as per configuration|]
liftIO $ pure <$> bindPortTCP port host
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
case sockets of
[] -> $logErrorS "bind" "No sockets to listen on"
[s] -> liftIO $ runWarp s
ss -> liftIO $ void . waitAnyCancel =<< mapM (async . runWarp) ss
--------------------------------------------------------------
@ -344,18 +407,19 @@ appMain = runResourceT $ do
--------------------------------------------------------------
foundationStoreNum :: Word32
foundationStoreNum = 2
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
handleJobs foundation
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
let foundationStore = Store foundationStoreNum
liftIO $ deleteStore foundationStore
liftIO $ writeStore foundationStore foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: MonadIO m => UniWorX -> m ()
@ -384,6 +448,6 @@ addPWEntry :: User
-> Text {-^ Password -}
-> IO ()
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
PWHashConf{..} <- getsYesod $ view _appAuthPWHash
(AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
void $ insert User{..}

2
src/Auth/LDAP.hs
View File

@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
]
-- ldapConfig :: UniWorX -> LDAPConfig
-- ldapConfig _app@(appSettings -> settings) = LDAPConfig
-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig
-- { usernameFilter = \u -> principalName <> "=" <> u
-- , identifierModifier
-- , ldapUri = appLDAPURI settings

23
src/CryptoID.hs
View File

@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..
import Data.Aeson.Encoding (text)
instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where
type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey
cryptoIDKey f = ask >>= f
-- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId
, ''FileId
@ -53,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece
newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
deriving (Show, Read, Eq)
pattern NewSubmission :: SubmissionMode
pattern NewSubmission = SubmissionMode Nothing
pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
pattern ExistingSubmission cID = SubmissionMode (Just cID)
instance PathPiece SubmissionMode where
fromPathPiece "new" = Just $ SubmissionMode Nothing
fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s
toPathPiece (SubmissionMode Nothing) = "new"
toPathPiece (SubmissionMode (Just x)) = toPathPiece x

22
src/Data/Aeson/Types/Instances.hs Normal file
View File

@ -0,0 +1,22 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Aeson.Types.Instances
(
) where
import ClassyPrelude
import Data.Aeson.Types (Parser, Value)
import Control.Monad.Catch
import Data.Binary (Binary)
import Data.HashMap.Strict.Instances ()
import Data.Vector.Instances ()
instance MonadThrow Parser where
throwM = fail . show
instance Binary Value

16
src/Data/HashMap/Strict/Instances.hs Normal file
View File

@ -0,0 +1,16 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.HashMap.Strict.Instances
(
) where
import ClassyPrelude
import Data.Binary (Binary(..))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where
put = put . HashMap.toList
get = HashMap.fromList <$> get

17
src/Data/HashSet/Instances.hs Normal file
View File

@ -0,0 +1,17 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.HashSet.Instances
(
) where
import ClassyPrelude
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Binary (Binary(..))
instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where
get = HashSet.fromList <$> get
put = put . HashSet.toList

28
src/Data/NonNull/Instances.hs Normal file
View File

@ -0,0 +1,28 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.NonNull.Instances
(
) where
import ClassyPrelude
import Data.Aeson
import Data.Binary (Binary)
import qualified Data.Binary as Binary
instance ToJSON a => ToJSON (NonNull a) where
toJSON = toJSON . toNullable
instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where
parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable
instance Hashable a => Hashable (NonNull a) where
hashWithSalt s = hashWithSalt s . toNullable
instance (Binary a, MonoFoldable a) => Binary (NonNull a) where
get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable
put = Binary.put . toNullable

14
src/Data/Set/Instances.hs Normal file
View File

@ -0,0 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Set.Instances
(
) where
import ClassyPrelude
import Data.Set (Set)
import qualified Data.Set as Set
instance (Ord a, Hashable a) => Hashable (Set a) where
hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs

26
src/Data/Time/Clock/Instances.hs Normal file
View File

@ -0,0 +1,26 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Time.Clock.Instances
(
) where
import ClassyPrelude
import Data.Time.Clock
import Data.Binary (Binary)
import qualified Data.Binary as Binary
deriving instance Generic UTCTime
instance Binary Day where
get = ModifiedJulianDay <$> Binary.get
put = Binary.put . toModifiedJulianDay
instance Binary DiffTime where
get = fromRational <$> Binary.get
put = Binary.put . toRational
instance Binary UTCTime

69
src/Data/Universe/TH.hs Normal file
View File

@ -0,0 +1,69 @@
module Data.Universe.TH
( finiteEnum
, deriveUniverse
, deriveFinite
) where
import Prelude
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Data.Universe
import Data.Universe.Helpers (interleave)
import Control.Monad (unless)
import Data.List (elemIndex)
finiteEnum :: Name -> DecsQ
-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances
finiteEnum tName = do
DatatypeInfo{..} <- reifyDatatype tName
let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
tUniverse = [e|universeF :: [$(datatype)]|]
[d|
instance Bounded $(datatype) where
minBound = head $(tUniverse)
maxBound = last $(tUniverse)
instance Enum $(datatype) where
toEnum n
| n >= 0
, n < length $(tUniverse)
= $(tUniverse) !! n
| otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds"
fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse)
enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))]
enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))]
|]
deriveUniverse, deriveFinite :: Name -> DecsQ
deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|]
deriveFinite tName = fmap concat . sequence $
[ deriveUniverse' [e|concat|] [e|universeF|] tName
, do
DatatypeInfo{..} <- reifyDatatype tName
[d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|]
]
deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ
deriveUniverse' interleaveExp universeExp tName = do
DatatypeInfo{..} <- reifyDatatype tName
let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars
consUniverse ConstructorInfo{..} = do
unless (null constructorVars) $
fail "Constructors with variables no supported"
foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields
pure <$> instanceD (cxt []) [t|Universe $(datatype)|]
[ funD 'universe
[ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) []
]
]

18
src/Data/Vector/Instances.hs Normal file
View File

@ -0,0 +1,18 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Vector.Instances
(
) where
import ClassyPrelude
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Data.Binary (Binary)
import qualified Data.Binary as Binary
instance Binary a => Binary (Vector a) where
get = Vector.fromList <$> Binary.get
put = Binary.put . Vector.toList

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

@ -7,6 +7,7 @@ module Database.Esqueleto.Utils
, SqlIn(..)
, mkExactFilter, mkExactFilterWith
, mkContainsFilter
, mkExistsFilter
, anyFilter, allFilter
) where
@ -18,9 +19,9 @@ import Database.Esqueleto.Utils.TH
--
-- Description : Convenience for using @Esqueleto@,
-- Description : Convenience for using `Esqueleto`,
-- intended to be imported qualified
-- just like Esqueleto
-- just like @Esqueleto@
-- ezero = E.val (0 :: Int64)
@ -43,13 +44,13 @@ hasInfix :: (E.Esqueleto query expr backend, E.SqlString s2) =>
hasInfix = flip isInfixOf
-- | Given a test and a set of values, check whether anyone succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether || is short curcuited (i.e. lazily evaluated)
-- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)
any :: Foldable f =>
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
any test = F.foldr (\needle acc -> acc E.||. test needle) false
-- | Given a test and a set of values, check whether all succeeds the test
-- WARNING: SQL leaves it explicitely unspecified whether && is short curcuited (i.e. lazily evaluated)
-- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated)
all :: Foldable f =>
(a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool)
all test = F.foldr (\needle acc -> acc E.&&. test needle) true
@ -81,7 +82,7 @@ mkExactFilter :: (PersistField a)
-> E.SqlExpr (E.Value Bool)
mkExactFilter = mkExactFilterWith id
-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
-- | like `mkExactFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter`
mkExactFilterWith :: (PersistField b)
=> (a -> b) -- ^ type conversion
-> (t -> E.SqlExpr (E.Value b)) -- ^ getter from query to searched element
@ -104,6 +105,15 @@ mkContainsFilter lenslike row criterias
| Set.null criterias = true
| otherwise = any (hasInfix $ lenslike row) criterias
mkExistsFilter :: PathPiece a
=> (t -> a -> E.SqlQuery ())
-> t
-> Set.Set a
-> E.SqlExpr (E.Value Bool)
mkExistsFilter query row criterias
| Set.null criterias = true
| otherwise = any (E.exists . query row) criterias
-- | Combine several filters, using logical or
anyFilter :: (Foldable f)
=> f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
@ -122,4 +132,4 @@ allFilter :: (Foldable f)
-> E.SqlExpr (E.Value Bool)
allFilter fltrs needle criterias = F.foldr aux true fltrs
where
aux fltr acc = fltr needle criterias E.&&. acc
aux fltr acc = fltr needle criterias E.&&. acc

27
src/Database/Persist/TH/Directory.hs
View File

@ -2,26 +2,35 @@ module Database.Persist.TH.Directory
( persistDirectoryWith
) where
import ClassyPrelude hiding (mapM_, toList)
import ClassyPrelude
import Database.Persist.TH (parseReferences)
import Database.Persist.Quasi (PersistSettings)
import Language.Haskell.TH.Syntax
import Language.Haskell.TH.Syntax hiding (lift)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified System.IO as SIO
import System.FilePath
import qualified System.Directory.Tree as DirTree
import Data.Foldable (Foldable(..), mapM_)
import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
import Control.Lens
persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp
persistDirectoryWith settings dir = do
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
Text.hGetContents h
mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files
files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do
fn <- MaybeT . return . fromNullable $ takeFileName fp
guard . not $ head fn == '.'
guard . not $ head fn == '#' && last fn == '#'
lift $ do
h <- SIO.openFile fp SIO.ReadMode
SIO.hSetEncoding h SIO.utf8_bom
Text.hGetContents h
mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files
parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files
parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files

12
src/Database/Persist/Types/Instances.hs Normal file
View File

@ -0,0 +1,12 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Persist.Types.Instances
(
) where
import ClassyPrelude
import Database.Persist.Types
instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal

658
src/Foundation.hs
View File

File diff suppressed because it is too large Load Diff

13
src/Handler/Admin.hs
View File

@ -122,7 +122,7 @@ postAdminTestR = do
let emailWidget' = wrapForm emailWidget def
{ formAction = Just . SomeRoute $ AdminTestR
, formEncoding = emailEnctype
, formAttrs = [("data-ajax-submit", "")]
, formAttrs = [("uw-async-form", "")]
}
@ -166,7 +166,7 @@ postAdminTestR = do
-- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
--
-- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required)
-- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required)
mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
-> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
-> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
@ -206,7 +206,7 @@ postAdminTestR = do
-- The actual call to @massInput@ is comparatively simple:
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing
((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout ("massinput" :: Text)) "" True Nothing
let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
@ -287,9 +287,6 @@ instance Button UniWorX ButtonAdminStudyTerms where
btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger]
-- END Button needed only here
sessionKeyNewStudyTerms :: Text
sessionKeyNewStudyTerms = "key-new-study-terms"
getAdminFeaturesR, postAdminFeaturesR :: Handler Html
getAdminFeaturesR = postAdminFeaturesR
postAdminFeaturesR = do
@ -305,7 +302,7 @@ postAdminFeaturesR = do
unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous
unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
let newKeys = map (StudyTermsKey' . fst) infAccepted
setSessionJson sessionKeyNewStudyTerms newKeys
setSessionJson SessionNewStudyTerms newKeys
if | null infAccepted
-> addMessageI Info MsgNoCandidatesInferred
| otherwise
@ -323,7 +320,7 @@ postAdminFeaturesR = do
Candidates.conflicts
_other -> runDB Candidates.conflicts
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms
( (degreeResult,degreeTable)
, (studyTermsResult,studytermsTable)
, ((), candidateTable)) <- runDB $ (,,)

19
src/Handler/Common.hs
View File

@ -8,10 +8,19 @@ import Import hiding (embedFile)
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $ TypedContent "image/x-icon"
$ toContent $(embedFile "static/favicon.ico")
getFaviconR = do
let content = $(embedFile "static/favicon.ico")
setEtagHashable content
return $ TypedContent "image/x-icon"
$ toContent content
getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "static/robots.txt")
getRobotsR = do
let content = $(embedFile "static/robots.txt")
setEtagHashable content
return $ TypedContent typePlain
$ toContent content

20
src/Handler/Corrections.hs
View File

@ -80,9 +80,6 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO
sheetIs :: Key Sheet -> CorrectionTableWhere
sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid
submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere
submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
-- Columns
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@ -131,7 +128,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
@ -350,7 +347,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \frag -> do
(actionRes, action) <- multiAction actions Nothing
(actionRes, action) <- multiActionM actions "" Nothing mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = _1
@ -702,7 +699,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
case uploadRes of
FormMissing -> return ()
@ -724,14 +721,16 @@ postCorrectionsUploadR = do
, formEncoding = uploadEncoding
}
defaultLayout
defaultLayout $ do
let uploadInstruction = $(i18nWidgetFile "corrections-upload-instructions")
$(widgetFile "corrections-upload")
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
getCorrectionsCreateR = postCorrectionsCreateR
postCorrectionsCreateR = do
uid <- requireAuthId
let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
let
isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_
@ -740,10 +739,9 @@ postCorrectionsCreateR = do
isLecturer = E.exists . E.from $ \lecturer -> E.where_
$ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.&&. ( isCorrector E.||. isLecturer )
E.where_ $ isCorrector E.||. isLecturer
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName))
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
mkOptList opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts

416
src/Handler/Course.hs
View File

@ -9,11 +9,14 @@ import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Course
import Handler.Utils.Tutorial
import Handler.Utils.Communication
import Handler.Utils.Form.MassInput
import Handler.Utils.Delete
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Handler.Utils.Invitations
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
@ -23,16 +26,22 @@ import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
import Data.Monoid (Last(..))
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Jobs.Queue
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
@ -271,7 +280,7 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(course,schoolName,participants,registration,defSFid,lecturers,assistants) <- runDB . maybeT notFound $ do
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors) <- 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
@ -297,7 +306,13 @@ getCShowR tid ssh csh = do
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
return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants)
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 )
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
@ -310,6 +325,78 @@ getCShowR tid ssh csh = do
, 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 <> textCell (CI.original tutorialName)
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
tutors <- 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 <- tutors
<li>
^{nameEmailWidget' tutor}
|]
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell 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"
tutorialDBTableValidator = def
& defaultSorting [SortAscBy "type", SortAscBy "name"]
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
siteLayout (toWgt $ courseName course) $ do
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course")
@ -348,6 +435,19 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist
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
@ -416,7 +516,7 @@ getCourseNewR = do
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
let newTemplate = courseToForm oldTemplate [] in
let newTemplate = courseToForm oldTemplate [] [] in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
@ -445,13 +545,14 @@ postCEditR = pgCEditR
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
courseLecs <- runDB $ do
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
return $ (,) <$> mbCourse <*> mbLecs
courseData <- runDB $ do
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
-- IMPORTANT: both GET and POST Handler must use the same template,
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ uncurry courseToForm <$> courseLecs
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
@ -479,7 +580,7 @@ courseEditHandler miButtonAction mbCourseForm = do
, cfTerm = tid
} -> do -- create new course
now <- liftIO getCurrentTime
insertOkay <- runDB $ do
insertOkay <- runDBJobs $ do
insertOkay <- insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
@ -495,8 +596,10 @@ courseEditHandler miButtonAction mbCourseForm = do
, courseDeregisterUntil = cfDeRegUntil res
}
whenIsJust insertOkay $ \cid -> do
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
insert_ $ CourseEdit aid now cid
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid
return insertOkay
case insertOkay of
Just _ -> do
@ -513,7 +616,7 @@ courseEditHandler miButtonAction mbCourseForm = do
} -> do -- edit existing course
now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do
success <- runDBJobs $ do
old <- get cid
case old of
Nothing -> addMessageI Error MsgInvalidInput $> False
@ -536,7 +639,11 @@ courseEditHandler miButtonAction mbCourseForm = do
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
deleteWhere [LecturerCourse ==. cid]
forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty)
deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid
addMessageI Success $ MsgCourseEditOk tid ssh csh
return True
@ -550,6 +657,65 @@ courseEditHandler miButtonAction mbCourseForm = do
}
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 { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData Lecturer) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
lecturerInvitationConfig :: InvitationConfig Lecturer
lecturerInvitationConfig = InvitationConfig{..}
where
invitationRoute Course{..} _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
invitationResolveFor = do
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject Course{..} _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading Course{..} _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) = hoistAForm liftHandlerT $ toJunction <$> case mlType of
Nothing -> areq (selectField optionsFinite) lFs Nothing
Just lType -> aforced (selectField optionsFinite) lFs lType
where
toJunction jLecturerType = JunctionLecturer{..}
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
invitationSuccessMsg Course{..} (Entity _ Lecturer{..}) = do
MsgRenderer mr <- getMsgRenderer
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
invitationUltDest Course{..} _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId
, cfName :: CourseName
@ -564,11 +730,11 @@ data CourseForm = CourseForm
, cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime
, cfDeRegUntil :: Maybe UTCTime
, cfLecturers :: [(UserId, LecturerType)]
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
}
courseToForm :: Entity Course -> [Lecturer] -> CourseForm
courseToForm (Entity cid Course{..}) lecs = CourseForm
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
@ -582,7 +748,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm
, cfRegFrom = courseRegisterFrom
, cfRegTo = courseRegisterTo
, cfDeRegUntil = courseDeregisterUntil
, cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs]
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
}
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
@ -609,29 +776,30 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
| otherwise -> termsSetField [cfTerm cform]
_allOtherCases -> return termsAllowedField
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId)))
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 (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ]
FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if
| lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ]
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid
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' = toWidget csrf >> fvInput addView >> fvInput btn
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType
miCell _ lid defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
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' = [whamlet|$newline never
#{csrf}
^{nameEmailWidget userEmail userDisplayName userSurname} #
^{fvInput lrwView}
|]
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 :: ListLength -- ^ Current shape
@ -642,14 +810,37 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
miAllowAdd _ _ _ = True
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
lecturerForm :: AForm Handler [(UserId,LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput
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 MsgCourseLecturerRightsIdentical)
(fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
True
(Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template)
(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)
@ -717,7 +908,7 @@ validateCourse CourseForm{..} = do
( NTop cfRegFrom <= NTop cfDeRegUntil
, MsgCourseDeregistrationEndMustBeAfterStart
)
, ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
, MsgCourseUserMustBeLecturer
)
] ]
@ -763,8 +954,9 @@ userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity Us
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 $ E.just (participant E.^. CourseParticipantUser) E.==. note E.?. CourseUserNoteUser
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
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)
@ -821,7 +1013,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
data CourseUserAction = CourseUserDeregister
data CourseUserAction = CourseUserSendMail | CourseUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseUserAction
@ -829,13 +1021,28 @@ instance Finite CourseUserAction
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CourseUserAction id
makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
makeCourseUserTable cid colChoices psValidator = do
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe TutorialUserAction
instance Finite TutorialUserAction
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''TutorialUserAction id
makeCourseUserTable :: forall h act.
( Functor h, ToSortable h
, RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
=> CourseId
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
-> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
-> DB (FormResult (act, Set UserId), Widget)
makeCourseUserTable cid restrict colChoices psValidator = do
Just currentRoute <- liftHandlerT getCurrentRoute
-- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery = userTableQuery cid
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
@ -876,14 +1083,22 @@ makeCourseUserTable cid colChoices psValidator = do
, 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) criterion
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 (searchField False) (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
, prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt (searchField False) (fslI MsgCourseTutorial)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
@ -901,7 +1116,7 @@ makeCourseUserTable cid colChoices psValidator = do
}
over _1 postprocess <$> dbTable psValidator DBTable{..}
where
postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool UserTableData) -> FormResult (CourseUserAction, Set UserId)
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
@ -925,9 +1140,12 @@ postCUsersR tid ssh csh = do
psValidator = def & defaultSortingByName
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
numParticipants <- count [CourseParticipantCourse ==. cid]
table <- makeCourseUserTable cid colChoices psValidator
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
@ -942,6 +1160,49 @@ postCUsersR tid ssh csh = do
$(widgetFile "course-participants")
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
let colChoices = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserName
, colUserEmail
, colUserMatriclenr
, colUserDegreeShort
, colUserField
, colUserSemester
]
psValidator = def
& defaultSortingByName
& restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
isInTut q = E.exists . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
table <- makeCourseUserTable cid isInTut colChoices psValidator
return (tut, table)
formResult participantRes $ \case
(TutorialUserSendMail, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
(TutorialUserDeregister,selectedUsers) -> do
nrDel <- runDB $ deleteWhereCount
[ TutorialParticipantTutorial ==. tutid
, TutorialParticipantUser <-. Set.toList selectedUsers
]
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
redirect $ CTutorialR tid ssh csh tutn TUsersR
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
@ -1039,3 +1300,62 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-- If they are shared, adjust MsgCourseUserNoteTooltip
getCNotesR = error "CNotesR: Not implemented"
postCNotesR = error "CNotesR: Not implemented"
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
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
return user
)
]
, crRecipientAuth = Just $ \uid -> do
cID <- encrypt uid
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
}
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCLecInviteR = postCLecInviteR
postCLecInviteR = invitationR lecturerInvitationConfig

81
src/Handler/Health.hs Normal file
View File

@ -0,0 +1,81 @@
module Handler.Health where
import Import
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Text.Lazy.Builder as Builder
import Utils.Lens
import qualified Data.UUID as UUID
getHealthR :: Handler TypedContent
getHealthR = do
healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
let
handleMissing = do
interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval
reportStore <- getsYesod appHealthReport
waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just)
case waitResult of
Left () -> fail "System is not generating HealthReports"
Right _ -> redirect HealthR
(lastUpdated, healthReport) <- maybe handleMissing return healthReport'
interval <- getsYesod $ view _appHealthCheckInterval
instanceId <- getsYesod appInstanceID
setWeakEtagHashable (instanceId, lastUpdated)
expiresAt $ interval `addUTCTime` lastUpdated
setLastModified lastUpdated
let status
| HealthSuccess <- classifyHealthReport healthReport
= ok200
| otherwise
= internalServerError500
sendResponseStatus status <=< selectRep $ do
provideRep . siteLayoutMsg MsgHealthReport $ do
setTitleI MsgHealthReport
let HealthReport{..} = healthReport
[whamlet|
$newline never
<dl .deflist>
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
<dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
$maybe httpReachable <- healthHTTPReachable
<dt .deflist__dt>_{MsgHealthHTTPReachable}
<dd .deflist__dd>#{boolSymbol httpReachable}
$maybe ldapAdmins <- healthLDAPAdmins
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
<dd .deflist__dd>#{textPercent ldapAdmins}
$maybe smtpConnect <- healthSMTPConnect
<dt .deflist__dt>_{MsgHealthSMTPConnect}
<dd .deflist__dd>#{boolSymbol smtpConnect}
$maybe widgetMemcached <- healthWidgetMemcached
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
<dd .deflist__dd>#{boolSymbol widgetMemcached}
|]
provideJson healthReport
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
getInstanceR :: Handler TypedContent
getInstanceR = do
instanceInfo@(clusterId, instanceId) <- getsYesod $ (,) <$> appClusterID <*> appInstanceID
setWeakEtagHashable (clusterId, instanceId)
selectRep $ do
provideRep $
siteLayoutMsg MsgInstanceIdentification $ do
setTitleI MsgInstanceIdentification
[whamlet|
$newline never
<dl .deflist>
<dt .deflist__dt>_{MsgClusterId}
<dd .deflist__dd style="font-family: monospace">#{UUID.toText clusterId}
<dt .deflist__dt>_{MsgInstanceId}
<dd .deflist__dd style="font-family: monospace">#{UUID.toText instanceId}
|]
provideJson instanceInfo
provideRep . return $ tshow instanceInfo

34
src/Handler/Help.hs
View File

@ -16,16 +16,18 @@ nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
data HelpForm = HelpForm
{ hfReferer:: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfRequest:: Text
{ hfReferer :: Maybe (Route UniWorX)
, hfUserId :: Either (Maybe Address) UserId
, hfSubject :: Maybe Text
, hfRequest :: Text
}
helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mReferer mUid = HelpForm
helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
helpForm mr mReferer mUid = HelpForm
<$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
<*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid)
<*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing
<*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing)
where
identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
identActions = Map.fromList $ case mUid of
@ -33,7 +35,7 @@ helpForm mReferer mUid = HelpForm
Nothing -> defaultActions
defaultActions =
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslpI MsgName $ mr MsgName) Nothing <*> apreq emailField (fslpI MsgEMail $ mr MsgEMail) Nothing))
, (HIAnonymous, pure $ Left Nothing)
]
@ -43,19 +45,16 @@ postHelpR = do
mUid <- maybeAuthId
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
isModal <- hasCustomHeader HeaderIsModal
MsgRenderer mr <- getMsgRenderer
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
let form = wrapForm formWidget def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}
((res,formWidget'),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid
formResultModal res HelpR $ \HelpForm{..} -> do
now <- liftIO getCurrentTime
hfReferer' <- traverse toTextUrl hfReferer
queueJob' JobHelpRequest
{ jSender = hfUserId
{ jHelpSender = hfUserId
, jSubject = hfSubject
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer'
@ -64,4 +63,9 @@ postHelpR = do
defaultLayout $ do
setTitleI MsgHelpTitle
let formWidget = wrapForm formWidget' def
{ formAction = Just $ SomeRoute HelpR
, formEncoding = formEnctype
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}
$(widgetFile "help")

5
src/Handler/Home.hs
View File

@ -128,7 +128,10 @@ homeUpcomingSheets uid = do
cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
case mbsid of
Nothing -> mempty
Nothing -> cell $ do
let submitRoute = CSheetR tid ssh csh shn SubmissionNewR
whenM (hasWriteAccessTo submitRoute) $
modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
(toWidget $ hasTickmark True)
]

301
src/Handler/Material.hs Normal file
View File

@ -0,0 +1,301 @@
module Handler.Material where
import Import
import Data.Monoid (Any(..))
import Data.Set (Set)
import qualified Data.Set as Set
-- import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Conduit.List as C
-- import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH
import Utils.Lens
import Utils.Form
import Handler.Utils
-- import Handler.Utils.Delete
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Control.Monad.Writer (MonadWriter(..), execWriterT)
data MaterialForm = MaterialForm
{ mfName :: MaterialName
, mfType :: Maybe Text
, mfDescription :: Maybe Html
, mfVisibleFrom :: Maybe UTCTime
, mfFiles :: Maybe (Source Handler (Either FileId File))
}
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
MsgRenderer mr <- getMsgRenderer
let setIds :: Either FileId File -> Set FileId
setIds = either Set.singleton $ const Set.empty
oldFileIds
| Just source <- template >>= mfFiles
= runConduit $ source .| C.foldMap setIds
| otherwise = return Set.empty
typeOptions :: WidgetT UniWorX IO (Set Text)
typeOptions = do
let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
previouslyUsed <- liftHandlerT . runDB $
E.select $ E.from $ \material ->
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
return $ material E.^. MaterialType
return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
flip (renderAForm FormStandard) html $ MaterialForm
<$> areq ciField (fslI MsgMaterialName) (mfName <$> template)
<*> aopt (textField & addDatalist typeOptions)
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
(mfType <$> template)
<*> aopt htmlField (fslpI MsgMaterialDescription "Html")
(mfDescription <$> template)
<*> aopt utcTimeField (fslI MsgMaterialVisibleFrom
& setTooltip MsgMaterialVisibleFromTip) ((mfVisibleFrom <$> template) <|> pure (Just ctime))
<*> aopt (multiFileField oldFileIds)
(fslI MsgMaterialFiles) (mfFiles <$> template)
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm = do
[matEnt] <- E.select . E.from $ -- uniqueness guaranteed by DB constraints
\(course `E.InnerJoin` material) -> do
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
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.&&. material E.^. MaterialName E.==. E.val mnm
return material
return matEnt
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialListR tid ssh csh = do
let matLink :: MaterialName -> Route UniWorX
matLink = CourseR tid ssh csh . flip MaterialR MShowR
now <- liftIO getCurrentTime
table <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
psValidator = def & defaultSorting [SortDescBy "last-edit"]
dbTableWidget' psValidator DBTable
{ dbtIdent = "material-list" :: Text
, dbtStyle = def
, dbtParams = def
, dbtSQLQuery = \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
return material
, dbtRowKey = (E.^. MaterialId)
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
, dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
, dbtColonnade = widgetColonnade $ mconcat
[ dbRow
, sortable (Just "type") (i18nCell MsgMaterialType)
$ foldMap textCell . materialType . row2material
, sortable (Just "name") (i18nCell MsgMaterialName)
$ liftA2 anchorCell matLink toWgt . materialName . row2material
, sortable (toNothingS "description") mempty
$ foldMap modalCell . materialDescription . row2material
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
, sortable (Just "last-edit") (i18nCell MsgFileModified)
$ dateTimeCell . materialLastEdit . row2material
]
, dbtSorting = Map.fromList
[ ( "type" , SortColumn (E.^. MaterialType) )
, ( "name" , SortColumn (E.^. MaterialName) )
, ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
]
, dbtFilter = mempty
, dbtFilterUI = mempty
}
let headingLong = prependCourseTitle tid ssh csh MsgMaterialListHeading
headingShort = prependCourseTitle tid ssh csh MsgMaterialListHeading
siteLayoutMsg headingLong $ do
setTitleI headingShort
$(widgetFile "material-list")
getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
getMFileR tid ssh csh mnm title = serveOneFile fileQuery
where
fileQuery = E.select $ E.from $
\(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile)
E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId)
E.on (material E.^. MaterialCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (material E.^. MaterialName E.==. E.val mnm )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMShowR tid ssh csh mnm = do
let matLink :: FilePath -> Route UniWorX
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
( Entity _mid material@Material{materialType, materialDescription}
, (Any hasFiles,fileTable)) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm
let psValidator = def & defaultSortingByFileTitle
fileTable' <- dbTable psValidator DBTable
{ dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
return (file E.^. FileTitle, file E.^. FileModified)
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = widgetColonnade $ mconcat
[ dbRowIndicator -- important: contains writer to indicate that the tables is not empty
, colFilePathSimple (view $ _dbrOutput . _1) matLink
, colFileModification (view $ _dbrOutput . _2)
]
, dbtProj = \dbr -> guardAuthorizedFor (matLink $ dbr ^. _dbrOutput . _1 . _Value) dbr
, dbtStyle = def
, dbtParams = def
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtIdent = "material-files" :: Text
, dbtSorting = Map.fromList
[ sortFilePath $(sqlIJproj 2 2)
, sortFileModification $(sqlIJproj 2 2)
]
}
return (matEnt,fileTable')
let matVisFro = materialVisibleFrom material
now <- liftIO getCurrentTime
materialLastEdit <- formatTime SelFormatDateTime $ materialLastEdit material
materialVisibleFrom <- traverse (formatTime SelFormatDateTime) matVisFro
when (NTop matVisFro >= NTop (Just now)) $ addMessageI Warning $
maybe MsgMaterialInvisible MsgMaterialInvisibleUntil materialVisibleFrom
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm
siteLayoutMsg headingLong $ do
setTitleI headingShort
$(widgetFile "material-show")
getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMEditR = postMEditR
postMEditR tid ssh csh mnm = do
(Entity mid Material{..}, files) <- runDB $ do
matEnt <- fetchMaterial tid ssh csh mnm
fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do
E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
return $ file E.^. FileId
return (matEnt, (Left . E.unValue) <$> fileIds)
-- let cid = materialCourse
let template = Just MaterialForm
{ mfName = materialName
, mfType = materialType
, mfDescription = materialDescription
, mfVisibleFrom = materialVisibleFrom
, mfFiles = Just $ yieldMany files
}
editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm
siteLayoutMsg headingLong $ do
setTitleI headingShort
editWidget
getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getMaterialNewR = postMaterialNewR
postMaterialNewR tid ssh csh = do
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique
let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading
headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle
siteLayoutMsg headingLong $ do
setTitleI headingShort
editWidget
handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
handleMaterialEdit tid ssh csh cid template dbMaterial = do
((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
formResult res saveMaterial
-- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
return $ wrapForm formWidget def
{ formAction = Nothing -- Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
where
saveMaterial :: MaterialForm -> Handler ()
saveMaterial MaterialForm{..} = do
_aid <- requireAuthId
now <- liftIO getCurrentTime
let newMaterial = Material
{ materialCourse = cid
, materialName = mfName
, materialType = mfType
, materialDescription = mfDescription
, materialVisibleFrom = mfVisibleFrom
, materialLastEdit = now
}
saveOk <- runDB $ do
mbmid <- dbMaterial newMaterial
case mbmid of
Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName)
(Just mid) -> do -- save files in DB
whenIsJust mfFiles $ insertMaterialFile' mid
addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName
-- more info/warnings could go here
return True
when saveOk $ redirect -- redirect must happen outside of runDB
$ CourseR tid ssh csh (MaterialR mfName MShowR)
insertMaterialFile' :: MaterialId -> Source Handler (Either FileId File) -> DB ()
insertMaterialFile' mid fs = do
oldFileIdVals <- E.select . E.from $ \(file `E.InnerJoin` materialFile) -> do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return $ file E.^. FileId
let oldFileIds = setFromList $ map E.unValue oldFileIdVals
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
where
finsert (Left fileId) = tell $ singleton fileId
finsert (Right file) = lift $ do
fid <- insert file
void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMDelR = postMDelR
postMDelR tid ssh csh mnm = do
_matEnt <- runDB $ fetchMaterial tid ssh csh mnm
error "todo" -- CONTINUE HERE
{-
deleteR DeleteRoute
{ drRecords = Set.singleton $ entityKey matEnt
, drGetInfo = error "todo"
, drUnjoin = error "todo"
, drRenderRecord = error "todo"
, drRecordConfirmString = error "todo"
, drCaption = SomeMessage MsgMaterialDeleteQuestion
, drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
, drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
}
-}

135
src/Handler/Profile.hs
View File

@ -27,7 +27,7 @@ data SettingsForm = SettingsForm
}
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template = identifyForm FIDsettings $ \html -> do
makeSettingForm template html = do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$ aformSection MsgFormCosmetics
<*> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
@ -42,11 +42,10 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
& setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template)
<* aformSection MsgFormNotifications
<*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
<*> notificationForm (stgNotificationSettings <$> template)
return (result, widget) -- no validation required here
where
themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
--
-- Version with proper grouping:
--
@ -76,6 +75,31 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do
-- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
-- 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)
data ButtonResetTokens = BtnResetTokens
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonResetTokens
instance Finite ButtonResetTokens
nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonResetTokens id
instance Button UniWorX ButtonResetTokens where
btnClasses BtnResetTokens = [BCIsButton, BCDanger]
data ProfileAnchor = ProfileSettings | ProfileResetTokens
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ProfileAnchor
instance Finite ProfileAnchor
nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1
getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
@ -89,37 +113,60 @@ postProfileR = do
, stgDownloadFiles = userDownloadFiles
, stgNotificationSettings = userNotificationSettings
}
((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
case res of
(FormSuccess SettingsForm{..}) -> do
runDB $ do
update uid [ UserMaxFavourites =. stgMaxFavourties
, UserTheme =. stgTheme
, UserDateTimeFormat =. stgDateTime
, UserDateFormat =. stgDate
, UserTimeFormat =. stgTime
, UserDownloadFiles =. stgDownloadFiles
, UserNotificationSettings =. stgNotificationSettings
]
when (stgMaxFavourties < userMaxFavourites) $ do
-- prune Favourites to user-defined size
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
, OffsetBy stgMaxFavourties
]
mapM_ delete oldFavs
addMessageI Info MsgSettingsUpdate
redirect ProfileR -- TODO: them change does not happen without redirect
((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate
(FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml
_ -> return ()
formResult res $ \SettingsForm{..} -> do
runDB $ do
update uid [ UserMaxFavourites =. stgMaxFavourties
, UserTheme =. stgTheme
, UserDateTimeFormat =. stgDateTime
, UserDateFormat =. stgDate
, UserTimeFormat =. stgTime
, UserDownloadFiles =. stgDownloadFiles
, UserNotificationSettings =. stgNotificationSettings
]
when (stgMaxFavourties < userMaxFavourites) $ do
-- prune Favourites to user-defined size
oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
, OffsetBy stgMaxFavourties
]
mapM_ delete oldFavs
addMessageI Info MsgSettingsUpdate
redirect $ ProfileR :#: ProfileSettings
((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm
formResult tokenRes $ \BtnResetTokens -> do
now <- liftIO getCurrentTime
runDB $ update uid [ UserTokensIssuedAfter =. Just now ]
addMessageI Info MsgTokensResetSuccess
redirect $ ProfileR :#: ProfileResetTokens
tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter
siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do
setTitle . toHtml $ "Profil " <> userIdent
wrapForm formWidget def
{ formAction = Just $ SomeRoute ProfileR
, formEncoding = formEnctype
}
let settingsForm =
wrapForm formWidget FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings
, formEncoding = formEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Just ProfileSettings
}
tokenForm =
wrapForm tokenFormWidget FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens
, formEncoding = tokenEnctype
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Just ProfileResetTokens
}
tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation")
$(widgetFile "profile/profile")
getProfileDataR :: Handler Html
@ -468,9 +515,9 @@ mkCorrectionsTable =
, sortable (toNothing "cload") (i18nCell MsgCorProportion) $
correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal)
, sortable (toNothing "assigned") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
int64Cell <$> view (_dbrOutput . _4 . _1 . _Value)
, sortable (toNothing "corrected") (i18nCell MsgCorProportion) $
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
int64Cell <$> view (_dbrOutput . _4 . _2 . _Value)
]
validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
@ -532,3 +579,27 @@ postAuthPredsR = do
siteLayoutMsg MsgAuthPredsActive $ do
setTitleI MsgAuthPredsActive
$(widgetFile "authpreds")
getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html
getUserNotificationR = postUserNotificationR
postUserNotificationR cID = do
uid <- decrypt cID
User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid
((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings
mJwt <- askJwt
isModal <- hasCustomHeader HeaderIsModal
let formWidget = wrapForm nsInnerWdgt def
{ formAction = Just . SomeRoute $ UserNotificationR cID
, formEncoding = nsEnc
, formAttrs = [ ("data-ajax-submit", "") | isModal ]
}
formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do
lift . runDB $ update uid [ UserNotificationSettings =. ns ]
tell . pure =<< messageI Success MsgNotificationSettingsUpdate
siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do
setTitleI $ MsgNotificationSettingsHeading userDisplayName
formWidget

451
src/Handler/Sheet.hs
View File

@ -1,28 +1,33 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Sheet where
import Import
import System.FilePath (takeFileName)
import Jobs.Queue
-- import Utils.Lens
import Utils.Sheet
import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
-- import Handler.Utils.Table.Columns
import Handler.Utils.SheetType
import Handler.Utils.Delete
import Handler.Utils.Form.MassInput
import Handler.Utils.Invitations
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
--
-- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text)
--
-- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C
-- import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
-- import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E
-- import qualified Database.Esqueleto.Internal.Sql as E
@ -36,13 +41,11 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
import Network.Mime
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Map (Map, (!?))
import Data.Map (Map, (!))
import Data.Monoid (Any(..))
@ -54,6 +57,9 @@ import Utils.Lens
import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
{-
* Implement Handlers
@ -69,8 +75,7 @@ data SheetForm = SheetForm
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
, sfSubmissionMode :: SheetSubmissionMode
, sfUploadMode :: UploadMode
, sfSubmissionMode :: SubmissionMode
, sfSheetF :: Maybe (Source Handler (Either FileId File))
, sfHintFrom :: Maybe UTCTime
, sfHintF :: Maybe (Source Handler (Either FileId File))
@ -95,10 +100,11 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
Nothing -> return $ partitionFileType mempty
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
mr <- getMsgRenderer
ctime <- liftIO $ getCurrentTime
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> aopt htmlField (fslpI MsgSheetDescription "Html")
(sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
(sfType <$> template)
@ -110,8 +116,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
<*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
@ -155,7 +160,8 @@ getSheetOldUnassigned tid ssh csh = runDB $ do
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
now <- liftIO getCurrentTime
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
@ -176,9 +182,9 @@ getSheetListR tid ssh csh = do
, sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty dateTimeCell mEditTime
, sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell sheetVisibleFrom
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
@ -304,43 +310,43 @@ getSShowR tid ssh csh shn = do
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade
let fileData (sheet' `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
let fileData (sheetFile `E.InnerJoin` file) = do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet' E.^. SheetId)
E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId)
-- filter to requested file
E.where_ $ sheet' E.^. SheetId E.==. E.val sid
E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories
-- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
, sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
(CSheetR tid ssh csh shn (SFileR fType fName))
(str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
(CSheetR tid ssh csh shn (SFileR fType fName))
(str2widget fName)
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
-- , colFileModification (view _2)
, sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified
]
let psValidator = def
& defaultSorting [SortAscBy "type", SortAscBy "path"]
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
, dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
-> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput
, dbtStyle = def
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtIdent = "files" :: Text
, dbtSorting = Map.fromList
[ ( "type"
, SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
, SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType
)
, ( "path"
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
)
, ( "time"
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
, SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified
)
]
, dbtParams = def
@ -365,7 +371,7 @@ getSShowR tid ssh csh shn = do
, formSubmit = FormNoSubmit
}
defaultLayout $ do
setTitleI $ MsgSheetTitle tid ssh csh shn
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
@ -399,34 +405,24 @@ postSPseudonymR tid ssh csh shn = do
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn typ title = do
results <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return desired columns
return $ (file E.^. FileTitle, file E.^. FileContent)
case results of
[(E.Value fileTitle, E.Value fileContent)]
| Just fileContent' <- fileContent -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
[] -> notFound
other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
where
fileQuery = E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do
@ -462,7 +458,6 @@ getSheetNewR tid ssh csh = do
, sfActiveFrom = addTime sheetActiveFrom
, sfActiveTo = addTime sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Nothing
, sfHintFrom = addTime <$> sheetHintFrom
, sfHintF = Nothing
@ -495,7 +490,6 @@ getSEditR tid ssh csh shn = do
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@ -504,11 +498,7 @@ getSEditR tid ssh csh shn = do
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
}
let action newSheet = do
replaceRes <- myReplaceUnique sid $ newSheet
case replaceRes of
Nothing -> return $ Just sid
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
@ -537,7 +527,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetActiveTo = sfActiveTo
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
}
@ -567,10 +556,11 @@ handleSheetEdit tid ssh csh msId template dbAction = do
actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
defaultLayout $ do
setTitleI pageTitle
wrapForm formWidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
let sheetEditForm = wrapForm formWidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}
$(i18nWidgetFile "sheet-edit")
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
@ -614,7 +604,7 @@ data CorrectorForm = CorrectorForm
, cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
}
type Loads = Map UserId (CorrectorState, Load)
type Loads = Map (Either UserEmail UserId) (CorrectorState, Load)
defaultLoads :: SheetId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required
@ -637,164 +627,151 @@ defaultLoads shid = do
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load)
correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let
guardNonDeleted :: UserId -> Handler (Maybe UserId)
guardNonDeleted uid = do
CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
return $ bool Just (const Nothing) (isJust deleted) uid
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector))
correctorForm shid = wFormToAForm $ do
Just currentRoute <- liftHandlerT getCurrentRoute
userId <- liftHandlerT requireAuthId
MsgRenderer mr <- getMsgRenderer
let
currentLoads :: DB Loads
currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
currentLoads = Map.union
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] [])
<*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid)
(defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
didDelete = any (flip Set.member deletions) formCIDs
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
let
tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
{ fieldView = \theId name attrs _val isReq -> asWidgetT $ do
listIdent <- newIdent
userId <- handlerToWidget requireAuthId
previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
return $ user E.^. UserEmail
[whamlet|
$newline never
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
<datalist id=#{listIdent}>
$forall E.Value prev <- previousCorrectors
<option value=#{prev}>
|]
}
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
loads <- case addTutRes of
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
case mUid of
Nothing -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
Just uid
| not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
| otherwise -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
_ -> return loads''
let deletions' = deletions `Set.difference` Map.keysSet loads
names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads)
return $ (user E.^. UserId, user E.^. UserDisplayName)
isWrite <- liftHandlerT $ isWriteRequest currentRoute
let
constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
constructFields (uid, uname, (state, Load{..})) = do
CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
let
fs name = ""
{ fsName = Just $ tshow ciphertext <> "-" <> name
}
rationalField = convertField toRational fromRational doubleField
applyDefaultLoads = Map.null currentLoads' && not isWrite
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
(stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
when (not (Map.null loads) && applyDefaultLoads) $
addMessageI Warning MsgCorrectorsDefaulted
countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
let
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
return user
miAdd :: ListPosition
-> Natural
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
, not $ null existing
-> FormFailure [mr MsgCorrectorExists]
| otherwise
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
return (addRes', $(widgetFile "sheetCorrectors/add"))
miCell :: ListPosition
-> Either UserEmail UserId
-> Maybe (CorrectorState, Load)
-> (Text -> Text)
-> Form (CorrectorState, Load)
miCell _ userIdent initRes nudge csrf = do
(stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
let
cfResult :: FormResult (CorrectorState, Load)
cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
res :: FormResult (CorrectorState, Load)
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes
cfUserId = uid
cfUserName = uname
return CorrectorForm{..}
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
return $ nameEmailWidget userEmail userDisplayName userSurname
return (res, $(widgetFile "sheetCorrectors/cell"))
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
mr <- getMessageRender
miDelete :: ListLength
-> ListPosition
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
miDelete = miDeleteList
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
miAllowAdd :: ListPosition
-> Natural
-> ListLength
-> Bool
miAllowAdd _ _ _ = True
let
corrColonnade = mconcat
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
, headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
]
corrResults
| FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing
| didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
| CorrectorForm{..} <- corrData
]
idField CorrectorForm{..} = do
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
miAddEmpty :: ListPosition
-> Natural
-> ListLength
-> Set ListPosition
miAddEmpty _ _ _ = Set.empty
delField uid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
miButtonAction :: forall p.
PathPiece p
=> p
-> Maybe (SomeRoute UniWorX)
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
-> Map ListPosition Widget
-> Map ListPosition (FieldView UniWorX)
-> Map (Natural, ListPosition) Widget
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
miIdent :: Text
miIdent = "correctors"
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector)
postProcess = Set.fromList . map postProcess' . Map.elems
where
sheetCorrectorSheet = shid
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector))
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
(,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
<*> correctorForm shid
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (autoDistribute, res') -> runDB $ do
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res'
let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors
deleteWhere [ SheetCorrectorSheet ==. shid ]
insertMany_ adds
deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites]
sinkInvitationsF correctorInvitationConfig invites
addMessageI Success MsgCorrectorsUpdated
FormMissing -> return ()
@ -804,3 +781,67 @@ getSCorrR tid ssh csh shn = do
{ formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR
, formEncoding = formEnctype
}
instance IsInvitableJunction SheetCorrector where
type InvitationFor SheetCorrector = Sheet
data InvitableJunction SheetCorrector = JunctionSheetCorrector
{ jSheetCorrectorLoad :: Load
, jSheetCorrectorState :: CorrectorState
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
{ invDBSheetCorrectorLoad :: Load
, invDBSheetCorrectorState :: CorrectorState
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
(\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
instance ToJSON (InvitableJunction SheetCorrector) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction SheetCorrector) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData SheetCorrector) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData SheetCorrector) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData SheetCorrector) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData SheetCorrector) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
correctorInvitationConfig :: InvitationConfig SheetCorrector
correctorInvitationConfig = InvitationConfig{..}
where
invitationRoute Sheet{..} _ = do
Course{..} <- get404 sheetCourse
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
invitationResolveFor = do
Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
fetchSheetId tid csh ssh shn
invitationSubject Sheet{..} _ = do
Course{..} <- get404 sheetCourse
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
invitationHeading 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
Course{..} <- get404 sheetCourse
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR = invitationR correctorInvitationConfig

10
src/Handler/Submission.hs
View File

@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing
getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid ssh csh shn = do
@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do
cID <- encrypt sid
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
submissionHelper tid ssh csh shn mcid = do
(Entity uid userData) <- requireAuth
msmid <- traverse decrypt mcid
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
let formWidget = wrapForm formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype

2
src/Handler/SystemMessage.hs
View File

@ -217,7 +217,7 @@ postMessageListR = do
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
]
(actionRes, action) <- multiAction actions (Just SMActivate)
(actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id

3
src/Handler/Term.hs
View File

@ -89,6 +89,7 @@ getTermShowR = do
cell $ do
termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
[whamlet|
$newline never
<ul .list--inline .list--comma-separated>
$forall holiday <- termHolidays'
<li>#{holiday}
@ -255,7 +256,7 @@ newTermForm template html = do
= aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
| otherwise
= areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) (fslI MsgTermHolidays) True (tftHolidays template) mempty
holidayForm = formToAForm . over (mapped._2) pure $ massInputList dayField (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder)) (const Nothing) ("holidays" :: Text) (fslI MsgTermHolidays & setTooltip MsgMassInputTip) True (tftHolidays template) mempty
(result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> tidForm
<*> areq dayField (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)

462
src/Handler/Tutorial.hs Normal file
View File

@ -0,0 +1,462 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Tutorial where
import Import
import Handler.Utils
import Handler.Utils.Tutorial
import Handler.Utils.Table.Cells
import Handler.Utils.Delete
import Handler.Utils.Communication
import Handler.Utils.Form.MassInput
import Handler.Utils.Form.Occurences
import Handler.Utils.Invitations
import Jobs.Queue
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils.TH
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import Utils.Lens
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
getCTutorialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialListR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let
tutorialDBTable = DBTable{..}
where
dbtSQLQuery tutorial = do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
let participants = E.sub_select . E.from $ \tutorialParticipant -> do
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
return (tutorial, participants)
dbtRowKey = (E.^. TutorialId)
dbtProj = return . over (_dbrOutput . _2) E.unValue
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{..}, _) } -> textCell $ CI.original tutorialName
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = (Entity tutid _, _) } -> sqlCell $ do
tutors <- 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 <- tutors
<li>
^{nameEmailWidget' tutor}
|]
, sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n
, sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime
, sortable (Just "reg-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup
, 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 mempty $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> cell $ do
linkButton mempty [whamlet|_{MsgTutorialEdit}|] [BCIsButton] . SomeRoute $ CTutorialR tid ssh csh tutorialName TEditR
linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR
]
dbtSorting = Map.fromList
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
, ("participants", SortColumn $ \tutorial -> E.sub_select . E.from $ \tutorialParticipant -> do
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
)
, ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity )
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
, ("reg-grep", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup )
, ("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"
tutorialDBTableValidator = def
& defaultSorting [SortAscBy "type", SortAscBy "name"]
((), tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
siteLayoutMsg (prependCourseTitle tid ssh csh MsgTutorialsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgTutorialsHeading
$(widgetFile "tutorial-list")
postTRegisterR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler ()
postTRegisterR tid ssh csh tutn = do
uid <- requireAuthId
Entity tutid Tutorial{..} <- runDB $ fetchTutorial tid ssh csh tutn
((btnResult, _), _) <- runFormPost buttonForm
formResult btnResult $ \case
BtnRegister -> do
runDB . void . insert $ TutorialParticipant tutid uid
addMessageI Success $ MsgTutorialRegisteredSuccess tutorialName
redirect $ CourseR tid ssh csh CShowR
BtnDeregister -> do
runDB . deleteBy $ UniqueTutorialParticipant tutid uid
addMessageI Success $ MsgTutorialDeregisteredSuccess tutorialName
redirect $ CourseR tid ssh csh CShowR
invalidArgs ["Register/Deregister button required"]
getTDeleteR, postTDeleteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTDeleteR = postTDeleteR
postTDeleteR tid ssh csh tutn = do
tutid <- runDB $ fetchTutorialId tid ssh csh tutn
deleteR DeleteRoute
{ drRecords = Set.singleton tutid
, drUnjoin = \(_ `E.InnerJoin` tutorial) -> tutorial
, drGetInfo = \(course `E.InnerJoin` tutorial) -> do
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
let participants = E.sub_select . E.from $ \participant -> do
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
return E.countRows
return (course, tutorial, participants :: E.SqlExpr (E.Value Int))
, drRenderRecord = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
return [whamlet|_{prependCourseTitle courseTerm courseSchool courseShorthand (CI.original tutorialName)} (#{tshow ps} _{MsgParticipantsN ps})|]
, drRecordConfirmString = \(Entity _ Course{..}, Entity _ Tutorial{..}, E.Value ps) ->
return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
, drCaption = SomeMessage MsgTutorialDeleteQuestion
, drSuccessMessage = SomeMessage MsgTutorialDeleted
, drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
, drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
}
getTCommR, postTCommR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTCommR = postTCommR
postTCommR tid ssh csh tutn = do
jSender <- requireAuthId
(cid, tutid) <- runDB $ fetchCourseIdTutorialId tid ssh csh tutn
commR CommunicationRoute
{ crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommTutorialHeading
, crUltDest = SomeRoute $ CTutorialR tid ssh csh tutn TCommR
, 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
[ ( RGTutorialParticipants
, E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
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
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
return user
)
]
, crRecipientAuth = Just $ \uid -> do
cID <- encrypt uid
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
}
instance IsInvitableJunction Tutor where
type InvitationFor Tutor = Tutorial
data InvitableJunction Tutor = JunctionTutor
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData Tutor = InvDBDataTutor
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData Tutor = InvTokenDataTutor
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\Tutor{..} -> (tutorUser, tutorTutorial, JunctionTutor))
(\(tutorUser, tutorTutorial, JunctionTutor) -> Tutor{..})
instance ToJSON (InvitableJunction Tutor) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction Tutor) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData Tutor) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData Tutor) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData Tutor) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData Tutor) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
tutorInvitationConfig :: InvitationConfig Tutor
tutorInvitationConfig = InvitationConfig{..}
where
invitationRoute Tutorial{..} _ = do
Course{..} <- get404 tutorialCourse
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
invitationResolveFor = do
Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
fetchTutorialId tid csh ssh tutn
invitationSubject Tutorial{..} _ = do
Course{..} <- get404 tutorialCourse
return . SomeMessage $ MsgMailSubjectTutorInvitation courseTerm courseSchool courseShorthand tutorialName
invitationHeading 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
Course{..} <- get404 tutorialCourse
return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CTutorialListR
getTInviteR, postTInviteR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTInviteR = postTInviteR
postTInviteR = invitationR tutorInvitationConfig
data TutorialForm = TutorialForm
{ tfName :: TutorialName
, tfType :: CI Text
, tfCapacity :: Maybe Int
, tfRoom :: Text
, tfTime :: Occurences
, tfRegGroup :: Maybe (CI Text)
, tfRegisterFrom :: Maybe UTCTime
, tfRegisterTo :: Maybe UTCTime
, tfDeregisterUntil :: Maybe UTCTime
, tfTutors :: Set (Either UserEmail UserId)
}
tutorialForm :: CourseId -> Maybe TutorialForm -> Form TutorialForm
tutorialForm cid template html = do
MsgRenderer mr <- getMsgRenderer
Just cRoute <- getCurrentRoute
uid <- liftHandlerT requireAuthId
let
tutorForm = Set.fromList <$> massInputAccumA miAdd' miCell' (\p -> Just . SomeRoute $ cRoute :#: p) miLayout' ("tutors" :: Text) (fslI MsgTutorialTutors & setTooltip MsgMassInputTip) True (Set.toList . tfTutors <$> template)
where
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd' nudge submitView csrf = do
(addRes, addView) <- mpreq (multiUserField False . Just $ tutUserSuggestions uid) ("" & addName (nudge "email")) Nothing
let
addRes'
| otherwise
= addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
, not $ Set.null existing
-> FormFailure [mr MsgTutorialTutorAlreadyAdded]
| otherwise
-> FormSuccess $ Set.toList newDat
return (addRes', $(widgetFile "tutorial/tutorMassInput/add"))
miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) =
$(widgetFile "tutorial/tutorMassInput/cellInvitation")
miCell' (Right userId) = do
User{..} <- liftHandlerT . runDB $ get404 userId
$(widgetFile "tutorial/tutorMassInput/cellKnown")
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "tutorial/tutorMassInput/layout")
flip (renderAForm FormStandard) html $ TutorialForm
<$> areq ciField (fslpI MsgTutorialName (mr MsgTutorialName) & setTooltip MsgTutorialNameTip) (tfName <$> template)
<*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template)
<*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template)
<*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template)
<*> occurencesAForm ("occurences" :: Text) (tfTime <$> template)
<*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial")))
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
& setTooltip MsgCourseRegisterFromTip
) (tfRegisterFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
& setTooltip MsgCourseRegisterToTip
) (tfRegisterTo <$> template)
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
& setTooltip MsgCourseDeregisterUntilTip
) (tfDeregisterUntil <$> template)
<*> tutorForm
where
tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
tutTypeDatalist = liftHandlerT . runDB $
fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
return $ tutorial E.^. TutorialType
tutUserSuggestions :: UserId -> E.SqlQuery (E.SqlExpr (Entity User))
tutUserSuggestions uid = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` tutorial `E.InnerJoin` tutor `E.InnerJoin` tutorUser) -> do
E.on $ tutorUser E.^. UserId E.==. tutor E.^. TutorUser
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return tutorUser
getCTutorialNewR, postCTutorialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCTutorialNewR = postCTutorialNewR
postCTutorialNewR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost $ tutorialForm cid Nothing
formResult newTutResult $ \TutorialForm{..} -> do
insertRes <- runDBJobs $ do
now <- liftIO getCurrentTime
insertRes <- insertUnique Tutorial
{ tutorialName = tfName
, tutorialCourse = cid
, tutorialType = tfType
, tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom
, tutorialTime = tfTime
, tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom
, tutorialRegisterTo = tfRegisterTo
, tutorialDeregisterUntil = tfDeregisterUntil
, tutorialLastChanged = now
}
whenIsJust insertRes $ \tutid -> do
let (invites, adds) = partitionEithers $ Set.toList tfTutors
insertMany_ $ map (Tutor tutid) adds
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
return insertRes
case insertRes of
Nothing -> addMessageI Error $ MsgTutorialNameTaken tfName
Just _ -> do
addMessageI Success $ MsgTutorialCreated tfName
redirect $ CourseR tid ssh csh CTutorialListR
let heading = prependCourseTitle tid ssh csh MsgTutorialNew
siteLayoutMsg heading $ do
setTitleI heading
let
newTutForm = wrapForm newTutWidget def
{ formMethod = POST
, formAction = Just . SomeRoute $ CourseR tid ssh csh CTutorialNewR
, formEncoding = newTutEnctype
}
$(widgetFile "tutorial-new")
getTEditR, postTEditR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTEditR = postTEditR
postTEditR tid ssh csh tutn = do
(cid, tutid, template) <- runDB $ do
(cid, Entity tutid Tutorial{..}) <- fetchCourseIdTutorial tid ssh csh tutn
tutorIds <- fmap (map E.unValue) . E.select . E.from $ \tutor -> do
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
return $ tutor E.^. TutorUser
tutorInvites <- sourceInvitationsList tutid
let
template = TutorialForm
{ tfName = tutorialName
, tfType = tutorialType
, tfCapacity = tutorialCapacity
, tfRoom = tutorialRoom
, tfTime = tutorialTime
, tfRegGroup = tutorialRegGroup
, tfRegisterFrom = tutorialRegisterFrom
, tfRegisterTo = tutorialRegisterTo
, tfDeregisterUntil = tutorialDeregisterUntil
, tfTutors = Set.fromList (map Right tutorIds)
<> Set.fromList (map (\(email, InvDBDataTutor) -> Left email) tutorInvites)
}
return (cid, tutid, template)
((newTutResult, newTutWidget), newTutEnctype) <- runFormPost . tutorialForm cid $ Just template
formResult newTutResult $ \TutorialForm{..} -> do
insertRes <- runDBJobs $ do
now <- liftIO getCurrentTime
insertRes <- myReplaceUnique tutid Tutorial
{ tutorialName = tfName
, tutorialCourse = cid
, tutorialType = tfType
, tutorialCapacity = tfCapacity
, tutorialRoom = tfRoom
, tutorialTime = tfTime
, tutorialRegGroup = tfRegGroup
, tutorialRegisterFrom = tfRegisterFrom
, tutorialRegisterTo = tfRegisterTo
, tutorialDeregisterUntil = tfDeregisterUntil
, tutorialLastChanged = now
}
when (is _Nothing insertRes) $ do
let (invites, adds) = partitionEithers $ Set.toList tfTutors
deleteWhere [ TutorTutorial ==. tutid ]
insertMany_ $ map (Tutor tutid) adds
deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ]
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
return insertRes
case insertRes of
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName
Nothing -> do
addMessageI Success $ MsgTutorialCreated tfName
redirect $ CourseR tid ssh csh CTutorialListR
let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template
siteLayoutMsg heading $ do
setTitleI heading
let
newTutForm = wrapForm newTutWidget def
{ formMethod = POST
, formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutn TEditR
, formEncoding = newTutEnctype
}
$(widgetFile "tutorial-edit")

2
src/Handler/Users.hs
View File

@ -52,6 +52,7 @@ getUsersR = do
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
$newline never
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
@ -63,6 +64,7 @@ getUsersR = do
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
$newline never
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}

35
src/Handler/Utils.hs
View File

@ -4,6 +4,8 @@ module Handler.Utils
import Import
import Utils.Lens
import qualified Data.Text as T
-- import qualified Data.Set (Set)
import qualified Data.Set as Set
@ -28,7 +30,9 @@ import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Mail as Handler.Utils
import System.Directory (listDirectory)
import System.FilePath.Posix (takeBaseName)
import System.FilePath.Posix (takeBaseName, takeFileName)
import Network.Mime
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
@ -40,9 +44,25 @@ downloadFiles = do
case mauth of
Just (Entity _ User{..}) -> return userDownloadFiles
Nothing -> do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles
-- | Serve a single file, identified through a given DB query
serveOneFile :: DB [Entity File] -> Handler TypedContent
serveOneFile query = do
results <- runDB query
case results of
[Entity _fileId File{fileTitle, fileContent}]
| Just fileContent' <- fileContent -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
[] -> notFound
other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
tidFromText :: Text -> Maybe TermId
tidFromText = fmap TermKey . maybeRight . termFromText
@ -99,7 +119,7 @@ wrapMailto (original -> email) linkText
-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $ toHtml email
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget
@ -169,3 +189,12 @@ i18nWidgetFile basename = do
| l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language
] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match
] [e|selectLanguage availableTranslations' >>= $(varE ws)|]
-- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val =
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)

190
src/Handler/Utils/Communication.hs Normal file
View File

@ -0,0 +1,190 @@
module Handler.Utils.Communication
( RecipientGroup(..)
, CommunicationRoute(..)
, Communication(..)
, commR
-- * Re-Exports
, Job(..)
) where
import Import
import Handler.Utils
import Handler.Utils.Form.MassInput
import Utils.Lens
import Jobs.Queue
import Control.Monad.Trans.Reader (mapReaderT)
import qualified Database.Esqueleto as E
import qualified Data.CaseInsensitive as CI
import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Aeson.TH
import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
| RGTutorialParticipants
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe RecipientGroup
instance Finite RecipientGroup
nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''RecipientGroup id
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''RecipientGroup
data RecipientCategory
= RecipientGroup RecipientGroup
| RecipientCustom
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveFinite ''RecipientCategory
finiteEnum ''RecipientCategory
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, unwrapUnaryRecords = True
, sumEncoding = UntaggedValue
} ''RecipientCategory
instance ToJSONKey RecipientCategory where
toJSONKey = toJSONKeyText toPathPiece
instance FromJSONKey RecipientCategory where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece
instance PathPiece RecipientCategory where
toPathPiece RecipientCustom = "custom"
toPathPiece (RecipientGroup g) = toPathPiece g
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX RecipientCategory where
renderMessage foundation ls = \case
RecipientCustom -> renderMessage' MsgRecipientCustom
RecipientGroup g -> renderMessage' g
where
renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
renderMessage' = renderMessage foundation ls
data CommunicationRoute = CommunicationRoute
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
, crRecipientAuth :: Maybe (UserId -> DB AuthResult)
, crJobs :: Communication -> Source (YesodDB UniWorX) Job
, crHeading :: SomeMessage UniWorX
, crUltDest :: SomeRoute UniWorX
}
data Communication = Communication
{ cRecipients :: Set (Either UserEmail UserId)
, cSubject :: Maybe Text
, cBody :: Html
}
commR :: CommunicationRoute -> Handler Html
commR CommunicationRoute{..} = do
cUser <- maybeAuth
MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ do
suggested <- for crRecipients $ \user -> E.select user
let
decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
decrypt' cID = do
uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid
chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient
return (suggested, chosen')
let
lookupUser :: UserId -> User
lookupUser lId
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients
let chosenRecipients' = Map.fromList $
[ ( (EnumPosition $ RecipientGroup g, pos)
, (Right recp, recp `elem` map entityKey chosenRecipients)
)
| (g, recps) <- Map.toList suggestedRecipients
, (pos, recp) <- zip [0..] $ map entityKey recps
] ++
[ ( (EnumPosition RecipientCustom, pos)
, (Right recp, True)
)
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
]
activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
miAdd _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientName"))
miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
miAllowAdd _ _ _ = False
miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
miAddEmpty _ _ _ = Set.empty
miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
-> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
-> Map (EnumPosition RecipientCategory, ListPosition) Widget
-> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
-> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
-> Widget
miLayout liveliness state cellWdgts _delButtons addWdgts = do
checkedIdentBase <- newIdent
let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state
checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
$(widgetFile "widgets/communication/recipientLayout")
miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
miDelete _ _ = mzero
miIdent :: Text
miIdent = "recipients"
postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
postProcess = Set.fromList . map fst . filter snd . Map.elems
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
<$> recipientAForm
<*> aopt textField (fslI MsgCommSubject) Nothing
<*> areq htmlField (fslI MsgCommBody) Nothing
formResult commRes $ \comm -> do
runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
redirect crUltDest
let formWdgt = wrapForm commWdgt def
{ formMethod = POST
, formAction = SomeRoute <$> mbCurrentRoute
, formEncoding = commEncoding
}
siteLayoutMsg crHeading $ do
setTitleI crHeading
formWdgt

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

@ -9,10 +9,13 @@ module Handler.Utils.DateTime
, addOneWeek, addWeeks
, weeksToAdd
, setYear
, ceilingQuarterHour
) where
import Import
import Utils.Lens
import Data.Time.Zones
import qualified Data.Time.Zones as TZ
@ -23,6 +26,8 @@ import qualified Data.Time.Format as Time
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Time.Clock.System (systemEpochDay)
utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@ -60,6 +65,9 @@ instance HasLocalTime Day where
instance HasLocalTime UTCTime where
toLocalTime = utcToLocalTime
instance HasLocalTime TimeOfDay where
toLocalTime = LocalTime systemEpochDay
formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
@ -83,7 +91,7 @@ getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
let
fmt
| Just (Entity _ User{..}) <- mauth
@ -182,4 +190,18 @@ weeksToAdd old new = loop 0 old
where
loop n t
| t > new = n
| otherwise = loop (succ n) (addOneWeek t)
| otherwise = loop (succ n) (addOneWeek t)
-- | round up the next full quarter hour with a margin of at least 5 minutes
ceilingQuarterHour :: UTCTime -> UTCTime
ceilingQuarterHour = ceilingMinuteBy 5 15
-- | round up the next full @roundto@ minutes with a margin of at least @margin@ minutes
ceilingMinuteBy :: Int -> Int -> UTCTime -> UTCTime
ceilingMinuteBy margin roundto utct = addUTCTime bonus utct
where
oldTime = localTimeOfDay $ utcToLocalTime utct
oldMin = todMin oldTime
newMin = roundToNearestMultiple roundto $ oldMin + margin
newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime`
bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime

2
src/Handler/Utils/Delete.hs
View File

@ -33,8 +33,8 @@ import qualified Database.Esqueleto.Internal.Language as E (From)
data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr info, E.From E.SqlQuery E.SqlExpr SqlBackend tables) => DeleteRoute
{ drRecords :: Set (Key record)
, drUnjoin :: tables -> E.SqlExpr (Entity record)
, drGetInfo :: tables -> E.SqlQuery infoExpr
, drUnjoin :: tables -> E.SqlExpr (Entity record)
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
, drCaption

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

@ -10,7 +10,7 @@ import Handler.Utils.Form.Types
import Handler.Utils.DateTime
import Import hiding (cons)
import Import
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
@ -33,12 +33,12 @@ import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class
import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)
import Data.Either (partitionEithers)
import Utils.Lens
@ -47,6 +47,8 @@ import Data.Aeson.Text (encodeToLazyText)
import Data.Proxy
import qualified Text.Email.Validate as Email
----------------------------
-- Buttons (new version ) --
----------------------------
@ -128,16 +130,67 @@ nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- instance PathPiece LinkButton where
-- LinkButton route = ???
linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = do
url' <- toTextUrl url
[whamlet|
$newline never
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
^{lbl}
|]
linkButton :: Widget -> Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton defWdgt lbl cls url = do
access <- evalAccess (urlRoute url) False
case access of
Unauthorized _ -> defWdgt
_other -> do
url' <- toTextUrl url
[whamlet|
$newline never
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
^{lbl}
|]
--------------------------
-- Interactive fieldset --
--------------------------
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
actionViews = Map.foldrWithKey accViews [] results
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm Handler a)
-> FieldSettings UniWorX
-> Maybe action
-> WForm Handler (FormResult a)
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
------------
-- Fields --
------------
@ -274,8 +327,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite
submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectField optionsFinite
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
where
uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
actions = Map.fromList
[ ( SubmissionModeNone
, pure $ SubmissionMode False Nothing
)
, ( SubmissionModeCorrector
, pure $ SubmissionMode True Nothing
)
, ( SubmissionModeUser
, SubmissionMode False . Just <$> uploadModeForm
)
, ( SubmissionModeBoth
, SubmissionMode True . Just <$> uploadModeForm
)
]
pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@ -295,11 +366,7 @@ zipFileField doUnpack = Field{..}
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
| null files = return $ Right Nothing
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
fieldView fieldId fieldName attrs _ req =
[whamlet|
$newline never
<input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
|]
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
multiFileField permittedFiles' = Field{..}
@ -339,7 +406,7 @@ multiFileField permittedFiles' = Field{..}
E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
E.orderBy [E.asc $ file E.^. FileTitle]
return (file E.^. FileId, file E.^. FileTitle)
$(widgetFile "multiFileField")
$(widgetFile "widgets/multiFileField")
unpackZips :: Text
unpackZips = "unpack-zip"
takeLefts :: Monad m => ConduitM (Either b a) b m ()
@ -377,7 +444,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Points', Points <$> maxPointsReq )
@ -395,7 +462,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Normal', Normal <$> gradingReq )
@ -414,8 +481,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
NotGraded -> NotGraded'
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
let
sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
@ -423,25 +490,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
]
(res, selView) <- multiAction selOptions (classify' <$> template)
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
where
classify' :: SheetGroup -> SheetGroup'
classify' = \case
Arbitrary _ -> Arbitrary'
@ -467,11 +515,8 @@ dayTimeField fs mutc = do
| otherwise = (Nothing,Nothing)
-}
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime
utcTimeField = Field
localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
localTimeField = Field
{ fieldParse = parseHelperGen readTime
, fieldView = \theId name attrs val isReq -> do
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
@ -487,13 +532,20 @@ utcTimeField = Field
fieldTimeFormat = "%Y-%m-%dT%H:%M"
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
readTime :: Text -> Either UniWorXMessage UTCTime
readTime :: Text -> Either UniWorXMessage LocalTime
readTime t =
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
Just LTUUnique{_ltuResult} -> Right _ltuResult
Just LTUNone{} -> Left MsgIllDefinedUTCTime
Just LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat
case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
Just lTime -> Right lTime
Nothing -> Left MsgInvalidDateTimeFormat
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField
where
localTimeToUTC' l = case localTimeToUTC l of
LTUUnique{_ltuResult} -> Right _ltuResult
LTUNone{} -> Left MsgIllDefinedUTCTime
LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
langField :: Bool -- ^ Only allow values from `appLanguages`
-> Field (HandlerT UniWorX IO) Lang
@ -621,49 +673,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts defAction = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) "" defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let mToWidget (_, []) = return Nothing
mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
widgets <- mapM mToWidget results
let actionWidgets = Map.foldrWithKey accWidget [] widgets
accWidget _act Nothing = id
accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
actionResults = Map.map fst results
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> FieldSettings UniWorX
-> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
(res, selView) <- multiAction acts defAction
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do
messages <- case res of
@ -677,3 +686,67 @@ formResultModal res finalDest handler = maybeT_ $ do
| otherwise -> do
forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
redirect finalDest
multiUserField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Bool -- ^ Only resolve suggested users?
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
-> Field m (Set (Either UserEmail UserId))
multiUserField onlySuggested suggestions = Field{..}
where
lookupExpr
| onlySuggested = suggestions
| otherwise = Just $ E.from return
fieldEnctype = UrlEncoded
fieldView theId name attrs val isReq = do
val' <- case val of
Left t -> return t
Right vs -> Text.intercalate ", " . map CI.original <$> do
let (emails, uids) = partitionEithers $ Set.toList vs
rEmails <- case lookupExpr of
Nothing -> return []
Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserId E.==. E.val uid
return $ user E.^. UserEmail
case dbRes of
[E.Value email] -> return [email]
_other -> return []
return $ emails ++ rEmails
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|]
whenIsJust suggestions $ \suggestions' -> do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
user <- suggestions'
return $ user E.^. UserEmail
[whamlet|
$newline never
<datalist id=#{datalistId}>
$forall email <- suggestedEmails
<option value=#{email}>
|]
fieldParse (all Text.null -> True) _ = return $ Right Nothing
fieldParse ts _ = runExceptT . fmap Just $ do
let ts' = concatMap (Text.splitOn ",") ts
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserEmail E.==. E.val email
return $ user E.^. UserId
case dbRes of
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> fail "Ambiguous e-mail addr"

304
src/Handler/Utils/Form/MassInput.hs
View File

@ -1,58 +1,46 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Utils.Form.MassInput
( MassInput(..)
( MassInput(..), MassInputLayout
, defaultMiLayout, listMiLayout
, massInput
, module Handler.Utils.Form.MassInput.Liveliness
, massInputA, massInputW
, massInputList
, BoxDimension(..)
, IsBoxCoord(..), boxDimension
, Liveliness(..)
, massInputAccum, massInputAccumA
, ListLength(..), ListPosition(..), miDeleteList
, EnumLiveliness(..), EnumPosition(..)
, MapLiveliness(..)
) where
import Import
import Utils.Form
import Utils.Lens
import Handler.Utils.Form (secretJsonField)
import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH
import Data.Aeson
import Algebra.Lattice
import Algebra.Lattice hiding (join)
import Text.Blaze (Markup)
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Foldable as Fold
import Data.List (genericLength, genericIndex, iterate)
import Control.Monad.Trans.Maybe
import Control.Monad.Reader.Class (MonadReader(local))
import Text.Hamlet (hamletFile)
data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
boxDimensions :: [BoxDimension x]
boxOrigin :: x
boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
boxDimension n
| n < genericLength dims = genericIndex dims n
| otherwise = error "boxDimension: insufficient dimensions"
where
dims = boxDimensions
-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
type BoxCoord a :: *
liveCoords :: Prism' (Set (BoxCoord a)) a
liveCoord :: BoxCoord a -> Prism' Bool a
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
$(mapM tupleBoxCoord [2..4])
newtype ListLength = ListLength { unListLength :: Natural }
@ -70,13 +58,13 @@ instance BoundedJoinSemiLattice ListLength where
bottom = 0
newtype ListPosition = ListPosition { unListPosition :: Natural }
deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''ListPosition
instance IsBoxCoord ListPosition where
boxDimensions = [BoxDimension id]
boxDimensions = [BoxDimension _Wrapped]
boxOrigin = 0
instance Liveliness ListLength where
@ -94,7 +82,66 @@ instance Liveliness ListLength where
= Nothing
where
max' = Set.lookupMax ns
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''EnumLiveliness
instance JoinSemiLattice (EnumLiveliness enum) where
(EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
instance MeetSemiLattice (EnumLiveliness enum) where
(EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
instance Lattice (EnumLiveliness enum)
instance BoundedJoinSemiLattice (EnumLiveliness enum) where
bottom = EnumLiveliness IntSet.empty
instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''EnumPosition
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
boxDimensions = [BoxDimension _Wrapped]
boxOrigin = minBound
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
type BoxCoord (EnumLiveliness enum) = EnumPosition enum
liveCoords = iso fromSet toSet
where
toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
deriving (Generic, Typeable)
makeWrapped ''MapLiveliness
deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
liveCoords = prism'
(Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
@ -187,7 +234,7 @@ data MassInputException = MassInputInvalidShape
instance Exception MassInputException
data MassInput handler liveliness cellData cellResult = MassInput
data MassInput handler liveliness cellData cellResult = forall i. PathPiece i => MassInput
{ miAdd :: BoxCoord liveliness -- Position (dimensions after @dimIx@ are zero)
-> Natural -- Zero-based dimension index @dimIx@
-> (Text -> Text) -- Nudge deterministic field ids
@ -205,9 +252,23 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Natural
-> liveliness
-> Bool -- ^ Decide whether an addition-operation should be permitted
, miAddEmpty :: BoxCoord liveliness
-> Natural
-> liveliness
-> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
, miLayout :: MassInputLayout liveliness cellData cellResult
, miIdent :: i
}
type MassInputLayout liveliness cellData cellResult
= liveliness
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
-> Map (BoxCoord liveliness) Widget -- Cell Widgets
-> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
-> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
-> Widget
massInput :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
@ -219,14 +280,14 @@ massInput :: forall handler cellData cellResult liveliness.
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
massInput MassInput{ miIdent = toPathPiece -> miIdent, ..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
fvId <- maybe newIdent return fsId
miAction <- traverse toTextUrl $ miButtonAction fvId
let addFormAction = maybe id (addAttr "formaction") miAction
let
shapeName :: MassInputFieldName (BoxCoord liveliness)
shapeName = MassInputShape{..}
@ -243,10 +304,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
addForm = addForm' boxOrigin . zip [0..]
addForm = addForm' boxOrigin [] . zip [0..]
where
addForm' _ [] = return Map.empty
addForm' miCoord ((dimIx, _) : remDims) = do
addForm' _ _ [] = return Map.empty
addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
let nudgeAddWidgetName :: Text -> Text
nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
(btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
@ -256,15 +317,19 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
wBtnRes res = do
guard $ isn't _FormMissing btnRes
res
addRes' <- over (mapped . _Just . _1) wBtnRes . local (bool id (set _1 Nothing) $ is _FormMissing btnRes) . traverse ($ mempty) $
miAdd miCoord dimIx nudgeAddWidgetName btnView
miAdd' = traverse ($ mempty) $ miAdd miCoord dimIx nudgeAddWidgetName btnView
addRes'' <- miAdd' & mapped . _Just . _1 %~ wBtnRes
addRes' <- fmap join . for addRes'' $ bool (return . Just) (\(res, _view) -> set (_Just . _1) res <$> local (set _1 Nothing) miAdd') (is (_Just . _FormSuccess) (fst <$> addRes'') || is _FormMissing btnRes)
let dimRes' = Map.singleton (dimIx, miCoord) (maybe (Nothing <$ btnRes) (fmap Just) $ fmap fst addRes', fmap snd addRes')
case remDims of
[] -> return dimRes'
((_, BoxDimension dim) : _) -> do
let
miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
let miCoords
= Set.union (miAddEmpty miCoord dimIx sentLiveliness)
. Set.map (\c -> miCoord & dim .~ (c ^. dim))
. Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
$ review liveCoords sentLiveliness
dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
return $ dimRes' `Map.union` fold dimRess
addResults <- addForm boxDimensions
@ -303,8 +368,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
shape <- if
| Just s <- addShape -> return s
| Just s <- delShape -> return s
| Just s <- addShape -> return s
| Just s <- delShape -> return s
| otherwise -> return sentShape'
liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
@ -342,25 +407,22 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
guard $ not shapeChanged
for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ [] = mempty
miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
cells
| [] <- remDims = do
coord <- coords
Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults
let deleteButton = snd <$> Map.lookup coord delResults
return (coord, $(widgetFile "widgets/massinput/cell"))
| otherwise =
[ (coord, miWidget' coord remDims) | coord <- coords ]
addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
in $(widgetFile "widgets/massinput/row")
miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
let miWidget
= miLayout
liveliness
(fmap (view _1 &&& view (_2 . _1)) cellResults)
(fmap (view $ _2 . _2) cellResults)
(fmap (view _2) delResults)
(Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
MsgRenderer mr <- getMsgRenderer
whenM ((== Just miIdent) <$> lookupCustomHeader HeaderMassInputShortcircuit) . liftHandlerT $ do
PageContent{..} <- widgetToPageContent $(widgetFile "widgets/massinput/massinput-standalone")
ur <- getUrlRenderParams
sendResponse $ $(hamletFile "templates/widgets/massinput/massinput-standalone-wrapper.hamlet") ur
let
fvLabel = toHtml $ mr fsLabel
fvTooltip = toHtml . mr <$> fsTooltip
@ -368,28 +430,144 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
fvErrors = Nothing
in return (result, FieldView{..})
defaultMiLayout :: forall liveliness cellData cellResult.
Liveliness liveliness
=> MassInputLayout liveliness cellData cellResult
-- | Generic `miLayout` using recursively nested lists
defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
where
miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ _ [] = mempty
miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
cells
| [] <- remDims = do
coord <- coords
Just cellWdgt <- return $ Map.lookup coord cellResults
let deleteButton = Map.lookup coord delResults
return (coord, $(widgetFile "widgets/massinput/cell"))
| otherwise =
[ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
addWidget = Map.lookup (dimIx, miCoord) addResults
in $(widgetFile "widgets/massinput/row")
listMiLayout :: MassInputLayout ListLength cellData cellResult
listMiLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/list/layout")
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult.
massInputList :: forall handler cellResult ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, PathPiece ident
)
=> Field handler cellResult
-> (ListPosition -> FieldSettings UniWorX)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellResult]
-> (Markup -> MForm handler (FormResult [cellResult], FieldView UniWorX))
massInputList field fieldSettings miButtonAction miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
massInputList field fieldSettings miButtonAction miIdent miSettings miRequired miPrevResult = over (mapped . _1 . mapped) (map snd . Map.elems) . massInput
MassInput { miAdd = \_ _ _ submitBtn -> Just $ \csrf ->
return (FormSuccess $ \pRes -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax pRes) (), toWidget csrf >> fvInput submitBtn)
, miCell = \pos () iRes nudge csrf ->
over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
, miDelete = miDeleteList
, miAllowAdd = \_ _ _ -> True
, miAddEmpty = \_ _ _ -> Set.empty
, miButtonAction
, miLayout = listMiLayout
, miIdent
}
miSettings
miRequired
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
-- | Wrapper around `massInput` for the common case, that we just want a list of data with no option to modify it except deletion and addition
massInputAccum :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
-> (cellData -> Widget)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> MassInputLayout ListLength cellData ()
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellData]
-> (Markup -> MForm handler (FormResult [cellData], FieldView UniWorX))
massInputAccum miAdd' miCell' miButtonAction miLayout miIdent fSettings fRequired mPrev csrf
= over (_1 . mapped) (map fst . Map.elems) <$> massInput MassInput{..} fSettings fRequired (Map.fromList . zip [0..] . map (, ()) <$> mPrev) csrf
where
miAdd :: ListPosition -> Natural
-> (Text -> Text) -> FieldView UniWorX
-> Maybe (Markup -> MForm handler (FormResult (Map ListPosition cellData -> FormResult (Map ListPosition cellData)), Widget))
miAdd _pos _dim nudge submitView = Just $ \csrf' -> over (_1 . mapped) doAdd <$> miAdd' nudge submitView csrf'
doAdd :: ([cellData] -> FormResult [cellData]) -> (Map ListPosition cellData -> FormResult (Map ListPosition cellData))
doAdd f prevData = Map.fromList . zip [startKey..] <$> f prevElems
where
prevElems = Map.elems prevData
startKey = maybe 0 succ $ fst <$> Map.lookupMax prevData
miCell :: ListPosition -> cellData -> Maybe () -> (Text -> Text)
-> (Markup -> MForm handler (FormResult (), Widget))
miCell _pos dat _mPrev _nudge csrf' = return (FormSuccess (), toWidget csrf' <> miCell' dat)
miDelete = miDeleteList
miAllowAdd _ _ _ = True
miAddEmpty _ _ _ = Set.empty
massInputAccumA :: forall handler cellData ident.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, MonadLogger handler
, ToJSON cellData, FromJSON cellData
, PathPiece ident
)
=> ((Text -> Text) -> FieldView UniWorX -> (Markup -> MForm handler (FormResult ([cellData] -> FormResult [cellData]), Widget)))
-> (cellData -> Widget)
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
-> MassInputLayout ListLength cellData ()
-> ident
-> FieldSettings UniWorX
-> Bool
-> Maybe [cellData]
-> AForm handler [cellData]
massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev
= formToAForm $ over _2 pure <$> massInputAccum miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired mPrev mempty
massInputA :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
massInputA mi fs fvRequired initialResult = formToAForm $
over _2 pure <$> massInput mi fs fvRequired initialResult mempty
massInputW :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
massInputW mi fs fvRequired initialResult = mFormToWForm $
massInput mi fs fvRequired initialResult mempty

45
src/Handler/Utils/Form/MassInput/Liveliness.hs Normal file
View File

@ -0,0 +1,45 @@
module Handler.Utils.Form.MassInput.Liveliness
( BoxDimension(..)
, IsBoxCoord(..)
, boxDimension
, Liveliness(..)
) where
import ClassyPrelude
import Web.PathPieces (PathPiece)
import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
import Numeric.Natural
import Utils.Lens
import Algebra.Lattice
import qualified Data.Set as Set
import Data.List (genericLength, genericIndex)
data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n)
class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where
boxDimensions :: [BoxDimension x]
boxOrigin :: x
boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
boxDimension n
| n < genericLength dims = genericIndex dims n
| otherwise = error "boxDimension: insufficient dimensions"
where
dims = boxDimensions
-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
type BoxCoord a :: *
liveCoords :: Prism' (Set (BoxCoord a)) a
liveCoord :: BoxCoord a -> Prism' Bool a
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))

40
src/Handler/Utils/Form/MassInput/TH.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Utils.Form.MassInput.TH
( tupleBoxCoord
) where
import Prelude
import Handler.Utils.Form.MassInput.Liveliness
import Language.Haskell.TH
import Control.Lens
import Data.List ((!!))
import Control.Monad (replicateM)
tupleBoxCoord :: Int -> DecQ
tupleBoxCoord tupleDim = do
cs <- replicateM tupleDim $ newName "c"
let tupleType = foldl appT (tupleT tupleDim) $ map varT cs
tCxt = cxt
[ [t|IsBoxCoord $(varT c)|] | c <- cs ]
fieldLenses =
[ [e|_1|]
, [e|_2|]
, [e|_3|]
, [e|_4|]
]
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
[ funD 'boxDimensions
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
]
, funD 'boxOrigin
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
]
]

124
src/Handler/Utils/Form/Occurences.hs Normal file
View File

@ -0,0 +1,124 @@
module Handler.Utils.Form.Occurences
( occurencesAForm
) where
import Import
import Handler.Utils.Form
import Handler.Utils.Form.MassInput
import Handler.Utils.DateTime
import qualified Data.Set as Set
import Data.Map ((!))
import qualified Data.Map as Map
import Utils.Lens
data OccurenceScheduleKind = ScheduleKindWeekly
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe OccurenceScheduleKind
instance Finite OccurenceScheduleKind
nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''OccurenceScheduleKind id
data OccurenceExceptionKind = ExceptionKindOccur
| ExceptionKindNoOccur
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe OccurenceExceptionKind
instance Finite OccurenceExceptionKind
nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''OccurenceExceptionKind id
occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences
occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do
Just cRoute <- getCurrentRoute
let
scheduled :: AForm Handler (Set OccurenceSchedule)
scheduled = Set.fromList <$> massInputAccumA
miAdd'
miCell'
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__scheduled" :: Text)
(fslI MsgScheduleRegular & setTooltip MsgMassInputTip)
False
(Set.toList . occurencesScheduled <$> mPrev)
where
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule])
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do
newSched <- multiActionW
(Map.fromList [ ( ScheduleKindWeekly
, ScheduleWeekly
<$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
)
]
) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing
MsgRenderer mr <- getMsgRenderer
return $ newSched <&> \newSched' oldScheds -> if
| newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists]
| otherwise -> FormSuccess $ pure newSched'
miCell' :: OccurenceSchedule -> Widget
miCell' ScheduleWeekly{..} = do
scheduleStart' <- formatTime SelFormatTime scheduleStart
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
$(widgetFile "widgets/occurence/form/weekly")
miLayout' :: MassInputLayout ListLength OccurenceSchedule ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout")
exceptions :: AForm Handler (Set OccurenceException)
exceptions = Set.fromList <$> massInputAccumA
miAdd'
miCell'
(\p -> Just . SomeRoute $ cRoute :#: p)
miLayout'
(miIdent' <> "__exceptions" :: Text)
(fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip]))
False
(Set.toList . occurencesExceptions <$> mPrev)
where
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException])
miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do
newExc <- multiActionW
(Map.fromList [ ( ExceptionKindOccur
, ExceptOccur
<$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing
<*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing
<*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing
)
, ( ExceptionKindNoOccur
, ExceptNoOccur
<$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing
)
]
) (fslI MsgExceptionKind & addName (nudge "kind")) Nothing
MsgRenderer mr <- getMsgRenderer
return $ newExc <&> \newExc' oldExcs -> if
| newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists]
| otherwise -> FormSuccess $ pure newExc'
miCell' :: OccurenceException -> Widget
miCell' ExceptOccur{..} = do
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
exceptEnd' <- formatTime SelFormatTime exceptEnd
$(widgetFile "widgets/occurence/form/except-occur")
miCell' ExceptNoOccur{..} = do
exceptTime' <- formatTime SelFormatDateTime exceptTime
$(widgetFile "widgets/occurence/form/except-no-occur")
miLayout' :: MassInputLayout ListLength OccurenceException ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout")
aFormToWForm $ Occurences
<$> scheduled
<*> exceptions

359
src/Handler/Utils/Invitations.hs Normal file
View File

@ -0,0 +1,359 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Handler.Utils.Invitations
( -- * Procedure
--
-- $procedure
IsInvitableJunction(..)
, Invitation'
, _invitationDBData, _invitationTokenData
, InvitationReference(..), invRef
, InvitationConfig(..), InvitationTokenConfig(..)
, sourceInvitations, sourceInvitationsList
, sinkInvitations, sinkInvitationsF
, invitationR', InvitationR(..)
) where
import Import
import Utils.Lens
import Utils.Form
import Jobs.Queue
import Handler.Utils.Tokens
import Text.Hamlet
import Control.Monad.Trans.Reader (mapReaderT)
import qualified Data.Conduit.List as C
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashSet as HashSet
import Data.Aeson (fromJSON)
import qualified Data.Aeson as JSON
import Data.Aeson.TH
import Data.Proxy (Proxy(..))
import Data.Typeable
class ( PersistRecordBackend junction (YesodPersistBackend UniWorX)
, ToJSON (InvitationDBData junction), ToJSON (InvitationTokenData junction)
, FromJSON (InvitationDBData junction), FromJSON (InvitationTokenData junction)
, PersistRecordBackend (InvitationFor junction) (YesodPersistBackend UniWorX)
, Typeable junction
) => IsInvitableJunction junction where
-- | One side of the junction is always `User`; `InvitationFor junction` is the other
type InvitationFor junction :: *
-- | `junction` without `Key User` and `Key (InvitationFor junction)`
data InvitableJunction junction :: *
-- | `InvitationData` is all data associated with an invitation except for the `UserEmail` and `InvitationFor junction`
--
-- Note that this is only the data associated with the invitation; some user input might still be required to construct `InvitableJunction junction`
type InvitationData junction = (dat :: *) | dat -> junction
type InvitationData junction = (InvitationDBData junction, InvitationTokenData junction)
-- | `InvitationDBData` is the part of `InvitationData` that is stored confidentially in the database
data InvitationDBData junction :: *
-- | `InvitationTokenData` is the part of `InvitationData` that is stored readably within the token
data InvitationTokenData junction :: *
_InvitableJunction :: Iso' junction (UserId, Key (InvitationFor junction), InvitableJunction junction)
_InvitationData :: Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction)
default _InvitationData :: InvitationData junction ~ (InvitationDBData junction, InvitationTokenData junction)
=> Iso' (InvitationData junction) (InvitationDBData junction, InvitationTokenData junction)
_InvitationData = id
-- | If `ephemeralInvitation` is not `Nothing` pending invitations are not stored in the database
--
-- In this case no invitation data can be stored in the database (@InvitationDBData junction ~ ()@)
ephemeralInvitation :: Maybe (AnIso' () (InvitationDBData junction))
ephemeralInvitation = Nothing
{-# MINIMAL _InvitableJunction #-}
_invitationDBData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationDBData junction)
_invitationDBData = _InvitationData . _1
_invitationTokenData :: IsInvitableJunction junction => Lens' (InvitationData junction) (InvitationTokenData junction)
_invitationTokenData = _InvitationData . _2
type Invitation' junction = (UserEmail, Key (InvitationFor junction), InvitationData junction)
data InvitationReference junction = IsInvitableJunction junction => InvRef (Key (InvitationFor junction))
deriving instance Eq (InvitationReference junction)
deriving instance Ord (InvitationReference junction)
deriving instance IsInvitableJunction junction => Read (InvitationReference junction)
deriving instance Show (InvitationReference junction)
instance ToJSON (InvitationReference junction) where
toJSON (InvRef fId) = JSON.object
[ "junction" JSON..= show (typeRep (Proxy @junction))
, "record" JSON..= fId
]
instance IsInvitableJunction junction => FromJSON (InvitationReference junction) where
parseJSON = JSON.withObject "InvitationReference" $ \o -> do
table <- o JSON..: "junction"
key <- o JSON..: "record"
unless (table == show (typeRep (Proxy @junction))) $
fail "Unexpected table"
return $ InvRef key
invRef :: forall junction. IsInvitableJunction junction => Key (InvitationFor junction) -> JSON.Value
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 :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (Route UniWorX)
-- ^ Which route calls `invitationR` for this kind of invitation?
, invitationResolveFor :: YesodDB UniWorX (Key (InvitationFor junction))
-- ^ Monadically resolve `InvitationFor` during `inviteR`
--
-- Usually from `requireBearerToken` or `getCurrentRoute`
, invitationSubject :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (SomeMessage UniWorX)
-- ^ Subject of the e-mail which sends the token to the user
, invitationHeading :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX (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)
-- ^ 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
-- ^ Parameters for creating the invitation token (`InvitationTokenData` is handled transparently)
, invitationRestriction :: InvitationFor junction -> InvitationData junction -> YesodDB UniWorX AuthResult
-- ^ Additional restrictions to check before allowing an user to redeem an invitation token
, invitationForm :: InvitationFor junction -> InvitationData junction -> AForm (YesodDB UniWorX) (InvitableJunction junction)
-- ^ Assimilate the additional data entered by the redeeming user
, invitationSuccessMsg :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (SomeMessage UniWorX)
-- ^ What to tell the redeeming user after accepting the invitation
, invitationUltDest :: InvitationFor junction -> Entity junction -> YesodDB UniWorX (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
{ itAuthority :: UserId
, itAddAuth :: Maybe AuthDNF
, itExpiresAt :: Maybe (Maybe UTCTime)
, itStartsAt :: Maybe UTCTime
} deriving (Generic, Typeable)
data InvitationTokenRestriction junction = IsInvitableJunction junction => InvitationTokenRestriction
{ itEmail :: UserEmail
, itData :: InvitationTokenData junction
}
deriving instance Eq (InvitationTokenData junction) => Eq (InvitationTokenRestriction junction)
deriving instance Ord (InvitationTokenData junction) => Ord (InvitationTokenRestriction junction)
deriving instance (Read (InvitationTokenData junction), IsInvitableJunction junction) => Read (InvitationTokenRestriction junction)
deriving instance Show (InvitationTokenData junction) => Show (InvitationTokenRestriction junction)
$(return [])
instance ToJSON (InvitationTokenRestriction junction) where
toJSON = $(mkToJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
instance IsInvitableJunction junction => FromJSON (InvitationTokenRestriction junction) where
parseJSON = $(mkParseJSON defaultOptions{ fieldLabelModifier = camelToPathPiece' 1 } ''InvitationTokenRestriction)
sinkInvitations :: forall junction.
IsInvitableJunction junction
=> InvitationConfig junction
-> Sink (Invitation' junction) (YesodJobDB UniWorX) ()
-- | Register invitations in the database
--
-- When an invitation for a certain junction (i.e. an `UserEmail`, `Key
-- (InvitationFor junction)`-Pair) already exists it's `InvitationData` is
-- updated, instead.
--
-- For new junctions an invitation is sent by e-mail.
sinkInvitations InvitationConfig{..} = determineExists .| C.foldMap pure >>= lift . sinkInvitations'
where
determineExists :: Conduit (Invitation' junction)
(YesodJobDB UniWorX)
(Either (InvitationId, InvitationData junction) (Invitation' junction))
determineExists
| is _Just (ephemeralInvitation @junction)
= C.map Right
| otherwise
= C.mapM $ \inp@(email, fid, dat) ->
maybe (Right inp) (Left . (, dat)) <$> getKeyBy (UniqueInvitation email (invRef @junction fid))
sinkInvitations' :: [Either (InvitationId, InvitationData junction) (Invitation' junction)]
-> YesodJobDB UniWorX ()
sinkInvitations' (partitionEithers -> (existing, 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_ new $ \(jInvitee, fid, dat) -> do
app <- getYesod
let mr = renderMessage app $ NonEmpty.toList appLanguages
ur <- getUrlRenderParams
fRec <- get404 fid
jInviter <- liftHandlerT requireAuthId
route <- mapReaderT liftHandlerT $ invitationRoute fRec dat
InvitationTokenConfig{..} <- mapReaderT liftHandlerT $ invitationTokenConfig fRec 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
queueDBJob JobInvitation{..}
sinkInvitationsF :: forall junction mono.
( IsInvitableJunction junction
, MonoFoldable mono
, Element mono ~ Invitation' junction
)
=> InvitationConfig junction
-> mono
-> YesodJobDB UniWorX ()
-- | Non-conduit version of `sinkInvitations`
sinkInvitationsF cfg invs = runConduit $ mapM_ yield invs .| sinkInvitations cfg
sourceInvitations :: forall junction.
IsInvitableJunction junction
=> Key (InvitationFor junction)
-> Source (YesodDB UniWorX) (UserEmail, InvitationDBData junction)
sourceInvitations forKey = selectSource [InvitationFor ==. invRef @junction forKey] [] .| C.mapM decode
where
decode (Entity _ (Invitation email _ invitationData))
= case fromJSON invitationData of
JSON.Success dbData -> return (email, dbData)
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
sourceInvitationsList :: forall junction.
IsInvitableJunction junction
=> Key (InvitationFor junction)
-> YesodDB UniWorX [(UserEmail, InvitationDBData junction)]
sourceInvitationsList forKey = runConduit $ sourceInvitations forKey .| C.foldMap pure
data ButtonInvite = BtnInviteAccept | BtnInviteDecline
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonInvite
instance Finite ButtonInvite
nullaryPathPiece ''ButtonInvite $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ButtonInvite id
instance Button UniWorX ButtonInvite where
btnClasses BtnInviteAccept = [BCIsButton, BCPrimary]
btnClasses BtnInviteDecline = [BCIsButton, BCDanger]
btnValidate _ BtnInviteAccept = True
btnValidate _ BtnInviteDecline = False
invitationR' :: forall junction m.
( IsInvitableJunction junction
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> InvitationConfig junction
-> m Html
-- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandlerT $ do
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId
Just cRoute <- getCurrentRoute
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
Entity fid fRec <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
dbData <- case ephemeralInvitation @junction of
Nothing -> do
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)
case fromJSON invitationData of
JSON.Success dbData -> return dbData
JSON.Error str -> fail $ "Could not decode invitationData: " <> str
Just (cloneIso -> _DBData) -> return $ view _DBData ()
let
iData :: InvitationData junction
iData = review _InvitationData (dbData, itData)
guardAuthResult =<< invitationRestriction fRec iData
((dataRes, dataWidget), dataEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
dataRes <- aFormToWForm $ invitationForm fRec iData
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
_other -> return $ Just <$> dataRes
MsgRenderer mr <- getMsgRenderer
ur <- getUrlRenderParams
heading <- invitationHeading fRec iData
let explanation = invitationExplanation fRec 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)
case mResult of
Nothing -> invalidArgsI [MsgInvitationCollision]
Just res -> do
deleteBy . UniqueInvitation itEmail $ invRef @junction fid
addMessageI Success =<< invitationSuccessMsg fRec res
Just <$> invitationUltDest fRec res
whenIsJust tRoute redirect
let formWidget = wrapForm dataWidget def
{ formMethod = POST
, formAction = Just $ SomeRoute cRoute
, formEncoding = dataEnctype
, formSubmit = FormNoSubmit
}
siteLayoutMsg heading $(widgetFile "widgets/invitation-site")
class InvitationR a where
invitationR :: forall junction.
( IsInvitableJunction junction
)
=> InvitationConfig junction
-> a
instance InvitationR (Handler Html) where
invitationR = invitationR'
instance InvitationR b => InvitationR (a -> b) where
invitationR cfg _ = invitationR cfg
-- $procedure
--
-- `Invitation`s encode a pending entry of some junction table between some
-- record and `User` e.g.
--
-- > data SheetCorrector = SheetCorrector
-- > { sheetCorrectorUser :: UserId
-- > , sheetCorrectorSheet :: SheetId
-- > , sheetCorrectorLoad :: Load
-- > }
--
-- We split the record, encoding a line in the junction table, into a `(UserId,
-- InvitationData)`-Pair, storing only part of the `InvitationData` in a
-- separate table (what we don't store in that table gets encoded into a
-- `BearerToken`).
--
-- After a User, authorized by said token, supplies their `UserId` the record is
-- completed and `insert`ed into the database.
--
-- We also make provisions for storing one side of the junction's `Key`s
-- (`InvitationFor`) separately from the rest of the `InvitationData` to make
-- querying for pending invitations easier.

17
src/Handler/Utils/Mail.hs
View File

@ -1,12 +1,13 @@
module Handler.Utils.Mail
( addRecipientsDB
, userAddress
, userMailT
, addFileDB
) where
import Import
import Utils.Lens hiding (snoc)
import Utils.Lens
import qualified Data.CaseInsensitive as CI
@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS
let addr = Address (Just userDisplayName) $ CI.original userEmail
_mailTo %= flip snoc addr
userAddress :: User -> Address
userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
userMailT :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadBaseControl IO m
, MonadLogger m
) => UserId -> MailT m a -> m a
userMailT uid mAct = do
User
{ userEmail
, userDisplayName
, userMailLanguages
user@User
{ userMailLanguages
, userDateTimeFormat
, userDateFormat
, userTimeFormat
} <- liftHandlerT . runDB $ getJust uid
let
addr = Address (Just userDisplayName) $ CI.original userEmail
ctx = MailContext
{ mcLanguages = userMailLanguages
, mcDateTimeFormat = \case
@ -55,7 +56,7 @@ userMailT uid mAct = do
SelFormatTime -> userTimeFormat
}
mailT ctx $ do
_mailTo .= pure addr
_mailTo .= pure (userAddress user)
mAct
addFileDB :: ( MonadMail m
@ -69,4 +70,4 @@ addFileDB fId = do
_partEncoding .= Base64
_partFilename .= Just fileName
_partContent .= LBS.fromStrict fileContent
setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

2
src/Handler/Utils/Rating.hs
View File

@ -18,8 +18,6 @@ import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
import Control.Monad.Trans.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (UnicodeException(..))

15
src/Handler/Utils/Sheet.hs
View File

@ -12,10 +12,10 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, Typeable a, MonadHandler m, IsPersistBackend backend
, PersistQueryRead backend, PersistUniqueRead backend
)
=> (E.SqlExpr (Entity Sheet) -> b)
=> (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, shn)
in cachedBy cachId $ do
-- Mit Yesod:
-- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
@ -27,19 +27,22 @@ fetchSheetAux prj tid ssh csh shn =
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet
return $ prj sheet course
case sheetList of
[sheet] -> return sheet
_other -> notFound
fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id
fetchSheet = fetchSheetAux const
fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
fetchSheetCourse = fetchSheetAux (,)
fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet

29
src/Handler/Utils/Submission.hs
View File

@ -79,32 +79,33 @@ assignSubmissions sid restriction = do
loadMap :: Map UserId Bool
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
-- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
-- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial)
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
return $ tutorial E.^. TutorialTutor
E.on $ tutor E.?. UserId `E.in_` E.justList tutors
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial)
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser)
E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
return $ tutor E.^. TutorUser
E.on $ tutor' E.?. UserId `E.in_` E.justList tutors
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
return (submission E.^. SubmissionId, tutor)
return (submission E.^. SubmissionId, tutor' E.?. UserId)
let subTutor' :: Map SubmissionId (Set UserId)
subTutor' = Map.fromListWith Set.union $ currentSubs
& mapped._2 %~ maybe Set.empty Set.singleton
& mapped._2 %~ Set.mapMonotonic entityKey
& mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue)
& mapped._1 %~ E.unValue
prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser
E.where_ $ tutor E.^. TutorUser E.==. sheetCorrector E.^. SheetCorrectorUser
E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)

1
src/Handler/Utils/Table.hs
View File

@ -63,6 +63,7 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
-> return Nothing
view _ name attributes val _ =
-- TODO: move this to a *.hamlet file
[whamlet|
<label style="display: block">
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>

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

@ -14,6 +14,10 @@ import Text.Blaze (ToMarkup(..))
import Utils.Lens
import Handler.Utils
import Utils.Occurences
import qualified Data.Set as Set
type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
@ -49,6 +53,13 @@ pathPieceCell = cell . toWidget . toPathPiece
sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a
sqlCell act = mempty & cellContents .~ lift act
markCell :: (IsDBTable m a) => (a -> Bool) -> (a -> DBCell m a) -> a -> DBCell m a
markCell condition normal x
| condition x = normal x <> cell (isVisibleWidget False)
| otherwise = normal x
-- Recall: for line numbers, use dbRow
---------------------
-- Icon cells
@ -71,6 +82,9 @@ commentCell Nothing = mempty
commentCell (Just link) = anchorCell link icon
where icon = toWidget $ hasComment True
-- | Display an icon that opens a modal upon clicking
modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)
-----------------
-- Datatype cells
@ -83,6 +97,12 @@ dateCell t = cell $ formatTime SelFormatDate t >>= toWidget
dateTimeCell :: IsDBTable m a => UTCTime -> DBCell m a
dateTimeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
dateTimeCellVisible :: IsDBTable m a => UTCTime -> UTCTime -> DBCell m a
dateTimeCellVisible watershed t = cell $ do
tfw <- formatTime SelFormatDateTime t >>= toWidget
icn <- bool mempty (toWidget $ isVisible False) $ watershed < t
return $ tfw <> icn
userCell :: IsDBTable m a => Text -> Text -> DBCell m a
userCell displayName surname = cell $ nameWidget displayName surname
@ -189,3 +209,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
correctorLoadCell sc =
i18nCell $ sheetCorrectorLoad sc
occurencesCell :: IsDBTable m a => Occurences -> DBCell m a
occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do
let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case
ScheduleWeekly{..} -> do
scheduleStart' <- formatTime SelFormatTime scheduleStart
scheduleEnd' <- formatTime SelFormatTime scheduleEnd
$(widgetFile "widgets/occurence/cell/weekly")
occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case
ExceptOccur{..} -> do
exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart)
exceptEnd' <- formatTime SelFormatTime exceptStart
$(widgetFile "widgets/occurence/cell/except-occur")
ExceptNoOccur{..} -> do
exceptTime' <- formatTime SelFormatDateTime exceptTime
$(widgetFile "widgets/occurence/cell/except-no-occur")
$(widgetFile "widgets/occurence/cell")

49
src/Handler/Utils/Table/Columns.hs
View File

@ -11,6 +11,7 @@ import Import
-- import Text.Blaze (ToMarkup(..))
import Data.Monoid (Any(..))
import qualified Database.Esqueleto as E
import Database.Esqueleto.Utils as E
@ -34,6 +35,54 @@ import Handler.Utils.Table.Cells
-- * additional helper, such as default sorting
-----------------------
-- Numbers and Indices
-- | Simple index column, also indicating whether there is a row at all
-- For a version without indication, use `Handler.Utils.Pagination.dbRow` instead.
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
---------------
-- Files
-- | Generic column for links to FilePaths, where the link depends on the entire table row
colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c)
colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell
where
makeCell row =
let filePath = E.unValue $ row2path row
link = row2link row
in anchorCell link $ str2widget filePath
-- | Generic column for links to FilePaths, where the link only depends on the FilePath itself
colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c)
colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell
where
makeCell row =
let filePath = E.unValue $ row2path row
link = row2link filePath
in anchorCell link $ str2widget filePath
-- | Generic column for File Modification
colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (dateTimeCell . E.unValue . row2time)
sortFilePath :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
sortFilePath queryPath = ("path", SortColumn $ queryPath >>> (E.^. FileTitle))
sortFileModification :: IsString s => (r -> E.SqlExpr (Entity File)) -> (s, SortColumn r)
sortFileModification queryModification = ("time", SortColumn $ queryModification >>> (E.^. FileModified))
defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x
defaultSortingByFileTitle = defaultSorting [SortAscBy "path"]
defaultSortingByFileModification :: PSValidator m x -> PSValidator m x
defaultSortingByFileModification = defaultSorting [SortAscBy "time"]
---------------
-- User names

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

@ -87,6 +87,15 @@ import Crypto.Hash.Algorithms (SHAKE256)
import qualified Data.ByteString.Base64.URL as Base64 (encode)
import qualified Data.ByteString.Lazy as LBS
import Data.Semigroup as Sem (Semigroup(..))
#if MIN_VERSION_base(4,11,0)
type Monoid' = Monoid
#else
type Monoid' x = (Sem.Semigroup x, Monoid x)
#endif
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
@ -404,7 +413,7 @@ data DBTable m x = forall a r r' h i t k k'.
, dbtIdent :: i
}
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid x, Monoid (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where
data DBParams m x :: *
type DBResult m x :: *
-- type DBResult' m x :: *
@ -428,7 +437,7 @@ cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
instance Monoid' x => IsDBTable (HandlerT UniWorX IO) x where
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = ()
@ -447,14 +456,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
dbHandler _ _ f = return . over _2 f
runDBTable _ _ _ = liftHandlerT
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
instance Monoid' x => Sem.Semigroup (DBCell (HandlerT UniWorX IO) x) where
(WidgetCell a c) <> (WidgetCell a' c') = WidgetCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
mappend = (<>)
instance Default (DBParams (HandlerT UniWorX IO) x) where
def = DBParamsWidget
instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
instance Monoid' x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
data DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBParamsDB
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
@ -472,9 +484,12 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable _ _ _ = mapReaderT liftHandlerT
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
(DBCell a c) <> (DBCell a' c') = DBCell (a <> a') ((<>) <$> c <*> c')
instance Monoid' x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
mempty = DBCell mempty $ return mempty
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
mappend = (<>)
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
def = DBParamsDB
@ -492,7 +507,7 @@ unDBParamsFormIdent DBTable{dbtIdent} DBParamsFormTableIdent = Just $ toP
unDBParamsFormIdent _ (DBParamsFormOverrideIdent x) = Just $ toPathPiece x
unDBParamsFormIdent _ DBParamsFormNoIdent = Nothing
instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
instance Monoid' x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x where
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x = forall a. DBParamsForm
{ dbParamsFormMethod :: StdMethod
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
@ -541,7 +556,7 @@ instance Monoid x => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
adjResult _ = FormFailure $ pure reasonTxt
return $ over (_1 . dbParamsFormResult) adjResult result
instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
def = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Nothing
@ -553,7 +568,7 @@ instance Monoid x => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [La
, dbParamsFormIdent = def
}
dbParamsFormWrap :: Monoid x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
dbParamsFormWrap :: Monoid' x => DBTable (MForm (HandlerT UniWorX IO)) x -> DBParams (MForm (HandlerT UniWorX IO)) x -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget)) -> (Html -> MForm (HandlerT UniWorX IO) (x, Widget))
dbParamsFormWrap DBTable{ dbtIdent } DBParamsForm{..} tableForm frag = do
let form = mappend <$> tableForm frag <*> (fmap (over _1 $ (flip $ set dbParamsFormResult) mempty) $ dbParamsFormAdditional mempty)
((res, fWidget), enctype) <- listen form
@ -588,14 +603,17 @@ addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
instance Monoid x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
instance Monoid' x => Sem.Semigroup (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
(FormCell attrs c l) <> (FormCell attrs' c' l') = FormCell (attrs <> attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', w <> w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
instance Monoid' x => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) x) where
mempty = FormCell mempty (return mempty) $ lens (\_ -> pure ()) (\s _ -> s)
(FormCell attrs c l) `mappend` (FormCell attrs' c' l') = FormCell (mappend attrs attrs') ((\(a, w) (a', w') -> ((,) <$> a <*> a', mappend w w')) <$> c <*> c') (lens (liftA2 (,) <$> view l <*> view l') (\s as -> s & l .~ (fst <$> as) & l' .~ (snd <$> as)))
mappend = (<>)
instance IsDBTable m a => IsString (DBCell m a) where
fromString = cell . fromString
-- | DB-backed tables with pagination, may short-circuit a handler
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DBResult m x)
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
let
@ -727,6 +745,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
isSortable = isJust sortableKey
isSorted = (`elem` directions)
attrs = sortableContent ^. cellAttrs
piSorting' = [ sSet | sSet <- fromMaybe [] piSorting, Just (sortKey sSet) /= sortableKey ]
return $(widgetFile "table/cell/header")
columnCount :: Int64
@ -778,24 +797,24 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key = setParams key . maybeToList
dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
dbTableWidget :: Monoid' x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> DB (DBResult (HandlerT UniWorX IO) x)
dbTableWidget = dbTable
dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> DB Widget
dbTableWidget' = fmap (fmap snd) . dbTable
widgetColonnade :: (Headedness h, Monoid x)
widgetColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade = id
formColonnade :: (Headedness h, Monoid a)
formColonnade :: (Headedness h, Monoid' a)
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade = id
dbColonnade :: (Headedness h, Monoid x)
dbColonnade :: (Headedness h, Monoid' x)
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade = id
@ -879,9 +898,12 @@ newtype DBFormResult i a r = DBFormResult (Map i (r, a -> a))
instance Functor (DBFormResult i a) where
f `fmap` (DBFormResult resMap) = DBFormResult $ fmap (over _1 f) resMap
instance Ord i => Sem.Semigroup (DBFormResult i a r) where
(DBFormResult m1) <> (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
instance Ord i => Monoid (DBFormResult i a r) where
mempty = DBFormResult Map.empty
(DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
mappend = (<>)
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
@ -909,11 +931,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
-- Predefined colonnades
--Number column?
-- | Simple number column, also see Handler.Utils.Table.Columns.dbRowIndicator
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid' x)
=> Lens' x (FormResult (DBFormResult i a (DBRow r)))
-> Setter' a Bool
-> (DBRow r -> MForm (HandlerT UniWorX IO) i)

34
src/Handler/Utils/Tokens.hs Normal file
View File

@ -0,0 +1,34 @@
module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken
, currentTokenRestrictions
) where
import Import
import Utils.Lens
import Control.Monad.Trans.Maybe (runMaybeT)
maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
where
cPred err = any ($ err)
[ is $ _HCError . _PermissionDenied
, is $ _HCError . _NotAuthenticated
]
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandlerT $ do
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
return token
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, FromJSON a, ToJSON a) => m (Maybe a)
currentTokenRestrictions = runMaybeT $ do
token <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ preview (_tokenRestrictionIx route) token

47
src/Handler/Utils/Tutorial.hs Normal file
View File

@ -0,0 +1,47 @@
module Handler.Utils.Tutorial
( fetchTutorialAux
, fetchTutorial, fetchTutorialId, fetchCourseIdTutorialId, fetchCourseIdTutorial
) where
import Import
import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
import Database.Esqueleto.Utils.TH
import Utils.Lens
fetchTutorialAux :: ( SqlBackendCanRead backend
, E.SqlSelect b a
, MonadHandler m
, Typeable a
)
=> (E.SqlExpr (Entity Tutorial) -> E.SqlExpr (Entity Course) -> b)
-> TermId -> SchoolId -> CourseShorthand -> TutorialName -> ReaderT backend m a
fetchTutorialAux prj tid ssh csh tutn =
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, tutn)
in cachedBy cachId $ do
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
E.on $ course E.^. CourseId E.==. tut E.^. TutorialCourse
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.&&. tut E.^. TutorialName E.==. E.val tutn
return $ prj tut course
case tutList of
[tut] -> return tut
_other -> notFound
fetchTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> DB (Entity Tutorial)
fetchTutorial = fetchTutorialAux const
fetchTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Tutorial)
fetchTutorialId tid ssh cid tutn = E.unValue <$> fetchTutorialAux (\tutorial _ -> tutorial E.^. TutorialId) tid ssh cid tutn
fetchCourseIdTutorialId :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Key Tutorial)
fetchCourseIdTutorialId tid ssh cid tutn = $(unValueN 2) <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. TutorialId)) tid ssh cid tutn
fetchCourseIdTutorial :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> YesodDB UniWorX (Key Course, Entity Tutorial)
fetchCourseIdTutorial tid ssh cid tutn = over _1 E.unValue <$> fetchTutorialAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid tutn

2
src/Handler/Utils/Zip.hs
View File

@ -23,7 +23,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import System.FilePath
import Data.Time
import Data.Time.LocalTime (localTimeToUTC, utcToLocalTime)
import Data.List (dropWhileEnd)

39
src/Import/NoFoundation.hs
View File

@ -3,21 +3,27 @@ module Import.NoFoundation
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
import Model.Rating as Import
import Model.Submission as Import
import Model.Tokens as Import
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Auth as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
import Utils as Import
import Utils.Modal as Import
import Utils.Frontend.Modal as Import
import Utils.Frontend.I18n as Import
import Yesod.Core.Json as Import (provideJson)
import Yesod.Core.Types.Instances as Import ()
import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
import Language.Haskell.TH.Instances as Import ()
import Utils.Tokens as Import
import Data.Fixed as Import
@ -30,6 +36,7 @@ import Text.Lucius as Import
import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import
import Data.Universe.TH as Import
import Data.Pool as Import (Pool)
import Network.HaskellNet.SMTP as Import (SMTPConnection)
@ -43,10 +50,16 @@ import GHC.Exts as Import (IsList)
import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.List.NonEmpty.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..))
import Data.Monoid.Instances as Import ()
import Data.Set.Instances as Import ()
import Data.HashMap.Strict.Instances as Import ()
import Data.HashSet.Instances as Import ()
import Data.Vector.Instances as Import ()
import Data.Time.Clock.Instances as Import ()
import Data.Binary as Import (Binary)
@ -56,17 +69,35 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Network.Mail.Mime.Instances as Import ()
import Yesod.Core.Instances as Import ()
import Data.Aeson.Types.Instances as Import ()
import Ldap.Client.Pool as Import
import Database.Esqueleto.Instances as Import ()
import Database.Persist.Sql.Instances as Import ()
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
import Database.Persist.Types.Instances as Import ()
import Numeric.Natural.Instances as Import ()
import System.Random as Import (Random)
import Control.Monad.Random.Class as Import (MonadRandom(..))
import Text.Blaze.Instances as Import ()
import Jose.Jwt.Instances as Import ()
import Jose.Jwt as Import (Jwt)
import Web.PathPieces.Instances as Import ()
import Data.Time.Calendar as Import
import Data.Time.Clock as Import
import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
import Time.Types as Import (WeekDay(..))
import Time.Types.Instances as Import ()
import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
import Data.Ratio as Import ((%))
import Control.Monad.Trans.RWS (RWST)

39
src/Jobs.hs
View File

@ -6,6 +6,7 @@ module Jobs
) where
import Import
import Utils.Lens
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Types (JobCtl(JobCtlQueue))
@ -46,11 +47,12 @@ import Control.Monad.Trans.Resource (MonadResourceBase, runResourceT, allocate,
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Data.Time.Clock
import Data.Time.Zones
import Control.Concurrent.STM (retry)
import qualified System.Systemd.Daemon as Systemd
import Jobs.Handler.SendNotification
import Jobs.Handler.SendTestEmail
@ -58,6 +60,10 @@ import Jobs.Handler.QueueNotification
import Jobs.Handler.HelpRequest
import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
import Jobs.Handler.SendCourseCommunication
import Jobs.Handler.Invitation
import Jobs.HealthReport
data JobQueueException = JInvalid QueuedJobId QueuedJob
@ -77,7 +83,7 @@ handleJobs :: ( MonadResource m
-- 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 = appJobWorkers appSettings
let num = foundation ^. _appJobWorkers
jobCrontab <- liftIO $ newTMVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
@ -135,7 +141,7 @@ execCrontab = evalStateT go HashMap.empty
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
refT <- liftIO getCurrentTime
settings <- getsYesod appSettings
settings <- getsYesod appSettings'
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of
@ -157,7 +163,7 @@ execCrontab = evalStateT go HashMap.empty
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
instanceID' <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
@ -166,7 +172,7 @@ execCrontab = evalStateT go HashMap.empty
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
, cronLastExecInstance = instanceID'
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
@ -277,6 +283,21 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
-- logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . void . flip swapTMVar newCTab =<< asks jobCrontab
handleCmd JobCtlGenerateHealthReport = do
hrStorage <- getsYesod appHealthReport
newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport
$logInfoS "HealthReport" $ toPathPiece newStatus
unless (newStatus == HealthSuccess) $ do
$logErrorS "HealthReport" $ tshow newReport
liftIO $ do
now <- getCurrentTime
atomically . writeTVar hrStorage $ Just (now, newReport)
void . Systemd.notifyStatus . unpack $ toPathPiece newStatus
when (newStatus == HealthSuccess) $
void Systemd.notifyWatchdog
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
jLocked jId act = do
@ -285,21 +306,21 @@ jLocked jId act = do
let
lock = runDB . setSerializable $ do
qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
instanceID <- getsYesod appInstanceID
threshold <- getsYesod $ appJobStaleThreshold . appSettings
instanceID' <- getsYesod $ view instanceID
threshold <- getsYesod $ view _appJobStaleThreshold
now <- liftIO getCurrentTime
hadStale <- maybeT (return False) $ do
lockTime <- MaybeT $ return queuedJobLockTime
lockInstance <- MaybeT $ return queuedJobLockInstance
if
| lockInstance == instanceID
| lockInstance == instanceID'
, diffUTCTime now lockTime >= threshold
-> return True
| otherwise
-> throwM $ JLocked jId lockInstance lockTime
when hadStale .
$logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
, QueuedJobLockTime =. Just now
]
liftIO . atomically $ writeTVar hasLock True

12
src/Jobs/Crontab.hs
View File

@ -11,7 +11,6 @@ import Data.Maybe (fromJust)
import qualified Data.Map as Map
import Data.Semigroup (Max(..))
import Data.Time
import Data.Time.Zones
import Control.Monad.Trans.Writer (execWriterT)
@ -23,7 +22,7 @@ import qualified Data.Conduit.List as C
determineCrontab :: DB (Crontab JobCtl)
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
determineCrontab = execWriterT $ do
AppSettings{..} <- getsYesod appSettings
AppSettings{..} <- getsYesod appSettings'
case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton
@ -45,6 +44,15 @@ determineCrontab = execWriterT $ do
, cronNotAfter = Right CronNotScheduled
}
tell $ HashMap.singleton
JobCtlGenerateHealthReport
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = appHealthCheckInterval
, cronNotAfter = Right CronNotScheduled
}
let
sheetJobs (Entity nSheet Sheet{..}) = do
tell $ HashMap.singleton

12
src/Jobs/Handler/HelpRequest.hs
View File

@ -16,20 +16,22 @@ import Data.Bitraversable
dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> UTCTime
-> Maybe Text -- ^ Help Subject
-> Text -- ^ Help Request
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
supportAddress <- getsYesod $ appMailSupport . appSettings
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let userAddress = either
let senderAddress = either
id
(fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
userInfo
mailT def $ do
_mailTo .= [supportAddress]
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
setSubjectI MsgMailSubjectSupport
whenIsJust senderAddress (_mailFrom .=)
replaceMailHeader "Auto-Submitted" $ Just "no"
setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
setDate jRequestTime
rtime <- formatTimeMail SelFormatDateTime jRequestTime
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

27
src/Jobs/Handler/Invitation.hs Normal file
View File

@ -0,0 +1,27 @@
module Jobs.Handler.Invitation
( dispatchJobInvitation
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import qualified Data.CaseInsensitive as CI
import Text.Hamlet
dispatchJobInvitation :: UserId
-> UserEmail
-> Text
-> Text
-> Html
-> Handler ()
dispatchJobInvitation jInviter jInvitee jInvitationUrl jInvitationSubject jInvitationExplanation = do
mInviter <- runDB $ get jInviter
whenIsJust mInviter $ \jInviter' -> mailT def $ do
_mailTo .= [Address Nothing $ CI.original jInvitee]
replaceMailHeader "Reply-To" . Just . renderAddress $ userAddress jInviter'
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
replaceMailHeader "Subject" $ Just jInvitationSubject
addPart ($(ihamletFile "templates/mail/invitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

37
src/Jobs/Handler/SendCourseCommunication.hs Normal file
View File

@ -0,0 +1,37 @@
module Jobs.Handler.SendCourseCommunication
( dispatchJobSendCourseCommunication
) where
import Import
import Utils.Lens
import Handler.Utils
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
dispatchJobSendCourseCommunication :: Either UserEmail UserId
-> Set Address
-> CourseId
-> UserId
-> UUID
-> Maybe Text
-> Html
-> Handler ()
dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do
(sender, Course{..}) <- runDB $ (,)
<$> getJust jSender
<*> getJust jCourse
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
void $ setMailObjectUUID jMailObjectUUID
_mailFrom .= userAddress sender
if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
| jRecipientEmail == Right jSender
-> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
| otherwise
-> addMailHeader "Cc" "Undisclosed Recipients:;"
addMailHeader "Auto-Submitted" "no"
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
void $ addPart jMailContent

7
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.CorrectionsAssigned
import Import
import Jobs.Handler.SendNotification.Utils
import Handler.Utils.Mail
import Text.Hamlet
@ -22,11 +23,13 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

1
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs
View File

@ -19,6 +19,7 @@ dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

7
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -7,6 +7,7 @@ module Jobs.Handler.SendNotification.SheetActive
import Import
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
@ -17,6 +18,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
@ -26,6 +28,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

13
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -8,6 +8,7 @@ module Jobs.Handler.SendNotification.SheetInactive
import Import
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
@ -20,6 +21,7 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
@ -29,8 +31,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@ -45,6 +48,7 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
-- E.distinctOn [E.don (subUser E.^. SubmissionUserUser)] -- Not necessary due to UniqueSubmisionUser
return (E.countRows :: E.SqlExpr (E.Value Int64))
return (course, sheet, nrSubs, nrSubmitters)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
@ -54,7 +58,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

5
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -9,6 +9,7 @@ import Import
import Utils.Lens
import Handler.Utils.DateTime
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.Aeson as Aeson
@ -22,6 +23,7 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
course <- belongsToJust sheetCourse sheet
corrector <- traverse getJust submissionRatingBy
return (course, sheet, submission, corrector)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
csid <- encrypt nSubmission
@ -34,6 +36,8 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
csh = courseShorthand
shn = sheetName
editNotifications <- mkEditNotifications jRecipient
-- TODO: provide convienience template-haskell for `addAlternatives`
addAlternatives $ do
provideAlternative $ Aeson.object
@ -51,5 +55,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
, "course-school" Aeson..= courseSchool
]
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

6
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -8,6 +8,7 @@ import Import
import Handler.Utils.Database
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
-- import qualified Data.CaseInsensitive as CI
@ -19,9 +20,10 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
adminSchools <- getSchoolsOf nUser UserAdminSchool UserAdminUser
lecturerSchools <- getSchoolsOf nUser UserLecturerSchool UserLecturerUser
return (user,adminSchools,lecturerSchools)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
-- MsgRenderer mr <- getMailMsgRenderer
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

20
src/Jobs/Handler/SendNotification/Utils.hs Normal file
View File

@ -0,0 +1,20 @@
module Jobs.Handler.SendNotification.Utils
( mkEditNotifications
) where
import Import
import Text.Hamlet
import qualified Data.HashSet as HashSet
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandlerT $ do
cID <- encrypt uid
jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
editNotificationsUrl' <- toTextUrl editNotificationsUrl
return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

1
src/Jobs/Handler/SendTestEmail.hs
View File

@ -13,6 +13,7 @@ import Utils.Lens
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail]
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailTestSubject
now <- liftIO getCurrentTime
nDT <- formatTimeMail SelFormatDateTime now

142
src/Jobs/HealthReport.hs Normal file
View File

@ -0,0 +1,142 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
module Jobs.HealthReport
( generateHealthReport
) where
import Import
import Data.List (genericLength)
import qualified Data.Aeson as Aeson
import Data.Proxy (Proxy(..))
import qualified Data.ByteArray as ByteArray
import Utils.Lens
import Network.HTTP.Simple (httpJSON, httpLBS)
import qualified Network.HTTP.Simple as HTTP
import qualified Database.Esqueleto as E
import Auth.LDAP
import qualified Data.CaseInsensitive as CI
import qualified Network.HaskellNet.SMTP as SMTP
import Data.Pool (withResource)
generateHealthReport :: Handler HealthReport
generateHealthReport
= runConcurrently $ HealthReport
<$> Concurrently matchingClusterConfig
<*> Concurrently httpReachable
<*> Concurrently ldapAdmins
<*> Concurrently smtpConnect
<*> Concurrently widgetMemcached
matchingClusterConfig :: Handler Bool
-- ^ Can the cluster configuration be read from the database and does it match our configuration?
matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
where
clusterSettingMatches ClusterCryptoIDKey = do
ourSetting <- getsYesod appCryptoIDKey
dbSetting <- clusterSetting @'ClusterCryptoIDKey
return $ ((==) `on` fmap (ByteArray.convert :: CryptoIDKey -> ByteString)) (Just ourSetting) dbSetting
clusterSettingMatches ClusterClientSessionKey = do
ourSetting <- getsYesod appSessionKey
dbSetting <- clusterSetting @'ClusterClientSessionKey
return $ Just ourSetting == dbSetting
clusterSettingMatches ClusterSecretBoxKey = do
ourSetting <- getsYesod appSecretBoxKey
dbSetting <- clusterSetting @'ClusterSecretBoxKey
return $ Just ourSetting == dbSetting
clusterSettingMatches ClusterJSONWebKeySet = do
ourSetting <- getsYesod appJSONWebKeySet
dbSetting <- clusterSetting @'ClusterJSONWebKeySet
return $ Just ourSetting == dbSetting
clusterSettingMatches ClusterId = do
ourSetting <- getsYesod appClusterID
dbSetting <- clusterSetting @'ClusterId
return $ Just ourSetting == dbSetting
clusterSetting :: forall key.
( ClusterSetting key
)
=> DB (Maybe (ClusterSettingValue key))
clusterSetting = do
current' <- get . ClusterConfigKey $ knownClusterSetting (Proxy @key)
case Aeson.fromJSON . clusterConfigValue <$> current' of
Just (Aeson.Success c) -> return $ Just c
_other -> return Nothing
httpReachable :: Handler (Maybe Bool)
httpReachable = do
staticAppRoot <- getsYesod $ view _appRoot
doHTTP <- getsYesod $ view _appHealthCheckHTTP
for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do
url <- getUrlRender <*> pure InstanceR
baseRequest <- HTTP.parseRequest $ unpack url
httpManager <- getsYesod appHttpManager
let httpRequest = baseRequest
& HTTP.setRequestManager httpManager
(clusterId, _ :: InstanceId) <- responseBody <$> httpJSON httpRequest
getsYesod $ (== clusterId) . appClusterID
ldapAdmins :: Handler (Maybe Rational)
ldapAdmins = do
ldapPool' <- getsYesod appLdapPool
ldapConf' <- getsYesod $ view _appLdapConf
ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
return $ user E.^. UserIdent
case (,) <$> ldapPool' <*> ldapConf' of
Just (ldapPool, ldapConf)
| not $ null ldapAdminUsers
-> do
let numAdmins = genericLength ldapAdminUsers
hCampusExc :: CampusUserException -> Handler (Sum Integer)
hCampusExc _ = return $ Sum 0
Sum numResolved <- fmap fold . forM ldapAdminUsers $
\(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
return . Just $ numResolved % numAdmins
_other -> return Nothing
smtpConnect :: Handler (Maybe Bool)
smtpConnect = do
smtpPool <- getsYesod appSmtpPool
for smtpPool . flip withResource $ \smtpConn -> do
response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
case rCode of
250 -> return True
_ -> do
$logErrorS "Mail" $ "NOOP failed: " <> tshow response
return False
widgetMemcached :: Handler (Maybe Bool)
widgetMemcached = do
memcachedConn <- getsYesod appWidgetMemcached
for memcachedConn $ \_memcachedConn' -> do
let ext = "bin"
mimeType = "application/octet-stream"
content <- pack . take 256 <$> liftIO getRandoms
staticLink <- addStaticContent ext mimeType content
doHTTP <- getsYesod $ view _appHealthCheckHTTP
case staticLink of
_ | not doHTTP -> return True
Just (Left url) -> do
baseRequest <- HTTP.parseRequest $ unpack url
httpManager <- getsYesod appHttpManager
let httpRequest = baseRequest
& HTTP.setRequestManager httpManager
(== content) . responseBody <$> httpLBS httpRequest
_other -> return False

32
src/Jobs/Queue.hs
View File

@ -2,11 +2,11 @@ module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, queueJob, queueJob'
, YesodJobDB
, runDBJobs, queueDBJob
, runDBJobs, queueDBJob, sinkDBJobs
, module Jobs.Types
) where
import Import
import Import hiding ((<>))
import Utils.Sql
import Jobs.Types
@ -21,6 +21,10 @@ import qualified Data.HashMap.Strict as HashMap
import Control.Monad.Random (evalRand, mkStdGen, uniform)
import qualified Data.Conduit.List as C
import Data.Semigroup ((<>))
data JobQueueException = JobQueuePoolEmpty
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@ -29,6 +33,10 @@ instance Exception JobQueueException
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => 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
tid <- liftIO myThreadId
wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
@ -39,6 +47,7 @@ writeJobCtl cmd = do
liftIO . atomically $ writeTMChan chan cmd
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
writeJobCtlBlock cmd = do
getResVar <- asks jobConfirm
resVar <- liftIO . atomically $ do
@ -67,19 +76,30 @@ queueJobUnsafe job = do
-- return jId
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' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
-- ^ `queueJob` followed by `JobCtlPerform`
-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
-- | Slightly modified Version of `YesodDB` for `runDBJobs`
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
queueDBJob :: 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
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
-- | Queue many jobs as part of a database transaction and execute them after the transaction passes
sinkDBJobs = C.mapM_ queueDBJob
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
--
-- Jobs get immediately executed if the transaction succeeds
runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
forM_ jIds $ writeJobCtl . JobCtlPerform

30
src/Jobs/Types.hs
View File

@ -15,11 +15,28 @@ import Data.List.NonEmpty (NonEmpty)
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jSender :: Either (Maybe Address) UserId
| JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
, jSubject :: Maybe Text
, jHelpRequest :: Text
, jReferer :: Maybe Text
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
| JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
, jAllRecipientAddresses :: Set Address
, jCourse :: CourseId
, jSender :: UserId
, jMailObjectUUID :: UUID
, jSubject :: Maybe Text
, jMailContent :: Html
}
| JobInvitation { jInviter :: UserId
, jInvitee :: UserEmail
, jInvitationUrl :: Text
, jInvitationSubject :: Text
, jInvitationExplanation :: Html
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
@ -34,15 +51,15 @@ instance Hashable Job
instance Hashable Notification
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "job" "data"
} ''Job
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "notification" "data"
} ''Notification
@ -52,6 +69,7 @@ data JobCtl = JobCtlFlush
| JobCtlPerform QueuedJobId
| JobCtlDetermineCrontab
| JobCtlQueue Job
| JobCtlGenerateHealthReport
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Hashable JobCtl

27
src/Jose/Jwt/Instances.hs Normal file
View File

@ -0,0 +1,27 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Jose.Jwt.Instances
(
) where
import ClassyPrelude.Yesod
import Jose.Jwt
deriving instance Ord Jwt
deriving instance Read Jwt
deriving instance Generic Jwt
deriving instance Typeable Jwt
instance PathPiece Jwt where
toPathPiece (Jwt bytes) = decodeUtf8 bytes
fromPathPiece = Just . Jwt . encodeUtf8
instance Hashable Jwt
deriving instance Generic JwtError
deriving instance Typeable JwtError
instance Exception JwtError

14
src/Language/Haskell/TH/Instances.hs Normal file
View File

@ -0,0 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.TH.Instances
(
) where
import Language.Haskell.TH
import Language.Haskell.TH.Lift (deriveLift)
import Data.Binary (Binary)
instance Binary Loc
deriveLift ''Loc

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

@ -95,7 +95,7 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
setup <- newEmptyTMVarIO
void . fork . flip runLoggingT logFunc $ do
$logDebugS "LdapExecutor" "Starting"
$logInfoS "LdapExecutor" "Starting"
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
case res of
Left exc -> do

82
src/Mail.hs
View File

@ -7,7 +7,9 @@ module Mail
module Network.Mail.Mime
-- * MailT
, MailT, defMailT
, MailSmtpData(..), MailContext(..), MailLanguages(..)
, MailSmtpData(..)
, _MailSmtpDataSet
, MailContext(..), MailLanguages(..)
, MonadMail(..)
, getMailMessageRender, getMailMsgRenderer
-- * YesodMail
@ -24,10 +26,12 @@ module Mail
, MailObjectId
, replaceMailHeader, addMailHeader, removeMailHeader
, replaceMailHeaderI, addMailHeaderI
, setSubjectI, setMailObjectId, setMailObjectId'
, setSubjectI
, setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
, setDate, setDateCurrent
, setMailSmtpData
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
, _addressName, _addressEmail
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
) where
@ -60,18 +64,19 @@ import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS
import Utils (MsgRendererS(..))
import Utils (MsgRendererS(..), MonadSecretBox(..))
import Utils.Lens.TH
import Control.Lens hiding (from)
import Control.Lens.Extras (is)
import Text.Blaze.Renderer.Utf8
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.UUID.Cryptographic.ImplicitNamespace
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import GHC.TypeLits (KnownSymbol)
@ -99,9 +104,25 @@ import Data.Universe.Instances.Reverse.Hashable ()
import GHC.Exts (IsList)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
import qualified Data.ByteArray as ByteArray (convert)
import Crypto.MAC.HMAC (hmac, HMAC)
import Crypto.Hash.Algorithms (SHAKE128)
makeLenses_ ''Address
makeLenses_ ''Mail
makeLenses_ ''Part
_mailHeader :: CI ByteString -> Traversal' Mail Text
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
@ -122,6 +143,13 @@ instance Monoid (MailSmtpData) where
mempty = memptydefault
mappend = mappenddefault
_MailSmtpDataSet :: Getter MailSmtpData Bool
_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
[ is (_Wrapped . _Nothing) smtpEnvelopeFrom
, Set.null smtpRecipients
]
newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
deriving newtype (FromJSON, ToJSON, IsList)
@ -415,20 +443,33 @@ setMailObjectUUID uuid = do
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
return objectId
setMailObjectId :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => m MailObjectId
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
setMailObjectIdRandom :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => m MailObjectId
setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
setMailObjectId' :: ( MonadHeader m
, YesodMail (HandlerSite m)
, MonadCrypto m
, HasCryptoUUID plain m
, MonadCryptoKey m ~ CryptoIDKey
, KnownSymbol (CryptoIDNamespace UUID plain)
, Binary plain
) => plain -> m MailObjectId
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
setMailObjectIdCrypto :: ( MonadHeader m
, YesodMail (HandlerSite m)
, MonadCrypto m
, HasCryptoUUID plain m
, MonadCryptoKey m ~ CryptoIDKey
, KnownSymbol (CryptoIDNamespace UUID plain)
, Binary plain
) => plain -> m MailObjectId
setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid
setMailObjectIdPseudorandom :: ( MonadHeader m
, YesodMail (HandlerSite m)
, Binary obj
, MonadSecretBox m
) => obj -> m MailObjectId
-- | Designed to leak no information about the `secretBoxKey` or the given object
setMailObjectIdPseudorandom obj = do
sbKey <- secretBoxKey
let
seed :: HMAC (SHAKE128 64)
seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
@ -443,7 +484,10 @@ setDate time = do
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setMailSmtpData = do
Address _ from <- use _mailFrom
Just (Address _ from) <- runMaybeT $ asum
[ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
, use _mailFrom
]
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
tell $ mempty { smtpRecipients = recps }

8
src/Model.hs
View File

@ -32,9 +32,11 @@ import Data.Binary (Binary)
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
$(persistDirectoryWith lowerCaseSettings "models")
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course)
deriving instance Eq (Unique Sheet)
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only; comments helpful for searching in code
deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; instance Eq TermSchoolCourseName
deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet
deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
-- Primary keys mentioned in dbtable row-keys must be Binary
-- Automatically generated (i.e. numeric) ids are already taken care of

43
src/Model/Migration.hs
View File

@ -21,6 +21,8 @@ import Database.Persist.Postgresql
import Text.Read (readMaybe)
import Data.CaseInsensitive (CI)
import Text.Shakespeare.Text (st)
-- 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)
@ -52,23 +54,28 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m ()
migrateAll = do
$logDebugS "Migration" "Initial migration"
mapM_ ($logInfoS "Migration") <=< runMigrationSilent $ do
-- Manual migrations to go to InitialVersion below:
migrateEnableExtension "citext"
migrateDBVersioning
appliedMigrations <- map entityKey <$> selectList [] []
$logDebugS "Migration" "Retrieve applied migrations"
appliedMigrations <- selectKeysList [] []
let
missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
doCustomMigration acc desc migration = acc <* do
let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
$logInfoS "Migration" [st|#{tshow appliedMigrationFrom} -> #{tshow appliedMigrationTo}|]
appliedMigrationTime <- liftIO getCurrentTime
_ <- migration
insert AppliedMigration{..}
-- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
$logDebugS "Migration" "Apply missing migrations"
Map.foldlWithKey doCustomMigration (return ()) missingMigrations
$logDebugS "Migration" "Persistent automatic migration"
mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll'
{-
@ -223,6 +230,28 @@ customMigrations = Map.fromListWith (>>)
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
)
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
[executeQQ|
ALTER TABLE "sheet" DROP COLUMN "upload_mode";
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
|]
forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
let submissionMode' = case (submissionMode, uploadMode) of
( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing
( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing
( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload)
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True)
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
)
, ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
, whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
tableDropEmpty "tutorial"
tableDropEmpty "tutorial_user"
)
]
@ -234,6 +263,18 @@ tableExists table = do
[Just _] -> return True
_other -> return False
tableIsEmpty :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableIsEmpty table = do
[rows] <- rawSql [st|SELECT COUNT(*) FROM "#{table}"|] []
return $ unSingle rows == (0 :: Int64)
tableDropEmpty :: MonadIO m => Text -> ReaderT SqlBackend m ()
tableDropEmpty table = do
isEmpty <- tableIsEmpty table
if
| isEmpty -> rawExecute [st|DROP TABLE "#{table}" CASCADE|] []
| otherwise -> fail $ "Table " <> unpack table <> " is not empty"
columnExists :: MonadIO m
=> Text -- ^ Table
-> Text -- ^ Column

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

@ -1,12 +1,17 @@
module Model.Migration.Types where
import ClassyPrelude.Yesod
import Data.Aeson
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Database.Persist.Sql
import Utils.PathPiece
import qualified Model as Current
import qualified Model.Types.JSON as Current
import Data.Universe
data SheetType
= Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
| Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@ -20,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..}
sheetType Pass {..} = Current.Normal Current.PassPoints {..}
sheetType NotGraded = Current.NotGraded
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
NoUpload -> "no-upload"
Upload True -> "unpack"
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
{- TODO:
* RenderMessage instance for newtype(SheetType) if needed
-}

149
src/Model/Tokens.hs Normal file
View File

@ -0,0 +1,149 @@
{-# LANGUAGE UndecidableInstances #-}
module Model.Tokens
( BearerToken(..)
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
, tokenRestrict
, tokenToJSON, tokenParseJSON
) where
import ClassyPrelude.Yesod
import Yesod.Core.Instances ()
import Model
import Utils (assertM')
import Utils.Lens hiding ((.=))
import Data.Aeson.Lens (AsJSON(..))
import Yesod.Auth (AuthId)
import Jose.Jwt (IntDate(..))
import qualified Jose.Jwt as Jose
import Jose.Jwt.Instances ()
import Data.Aeson.Types.Instances ()
import Data.HashSet (HashSet)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict.Instances ()
import Data.HashSet.Instances ()
import Data.Time.Clock.Instances ()
import Data.Aeson.Types (Parser, (.:?), (.:), (.!=), (.=))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import CryptoID
import Data.Time.Clock.POSIX
import Data.Binary (Binary)
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
data BearerToken site = BearerToken
{ tokenIdentifier :: TokenId
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
, tokenAuthority :: AuthId site
-- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
, tokenRoutes :: Maybe (HashSet (Route site))
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
, tokenAddAuth :: Maybe AuthDNF
-- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
, tokenRestrictions :: HashMap (Route site) Value
-- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
--
-- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
, tokenIssuedAt :: UTCTime
, tokenIssuedBy :: InstanceId
, tokenExpiresAt
, tokenStartsAt :: Maybe UTCTime
} deriving (Generic, Typeable)
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
makeLenses_ ''BearerToken
_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
-- ^ Focus a singular restriction (by route) if it exists
--
-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
-- ^ Focus a singular restriction (by route) whether it exists, or not
_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
-- ^ Add a restriction to a `BearerToken`
--
-- If a restriction already exists for the targeted route, it's silently overwritten
tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
tokenToJSON :: forall m.
( MonadHandler m
, HasCryptoUUID (AuthId (HandlerSite m)) m
, RenderRoute (HandlerSite m)
) => BearerToken (HandlerSite m) -> m Value
-- ^ Encode a `BearerToken` analogously to `toJSON`
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do
cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing
, jwtAud = Nothing
, jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
, jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
, jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
, jwtJti = Just $ toPathPiece tokenIdentifier
}
return . JSON.object $
catMaybes [ Just $ "authority" .= cID
, ("routes" .=) <$> tokenRoutes
, ("add-auth" .=) <$> tokenAddAuth
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
]
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
tokenParseJSON :: forall site.
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
, ParseRoute site
, Hashable (Route site)
)
=> Value
-> ReaderT CryptoIDKey Parser (BearerToken site)
-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
--
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
tokenAuthority <- decrypt tokenAuthority'
tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth"
tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
Jose.JwtClaims{..} <- lift $ parseJSON v
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
let tokenExpiresAt = unIntDate <$> jwtExp
tokenStartsAt = unIntDate <$> jwtNbf
return BearerToken{..}
tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v

231
src/Model/Types.hs
View File

@ -24,9 +24,12 @@ import Data.Monoid (Sum(..))
import Data.Maybe (fromJust)
import Data.Universe
import Data.Universe.Helpers
import Data.Universe.TH
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
import Data.NonNull.Instances ()
import Data.Default
import Text.Read (readMaybe)
@ -54,7 +57,7 @@ import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@ -79,6 +82,14 @@ import Model.Types.Wordlist
import Data.Text.Metrics (damerauLevenshtein)
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Time.Types (WeekDay(..))
import Data.Time.LocalTime (LocalTime, TimeOfDay)
import Data.Semigroup (Min(..))
import Control.Monad.Trans.Writer (execWriter)
import Control.Monad.Writer.Class (MonadWriter(..))
instance PathPiece UUID where
@ -286,12 +297,14 @@ instance DisplayAble DA where
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
derivePersistFieldJSON ''UploadMode
deriveFinite ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
, fieldLabelModifier = camelToPathPiece
, sumEncoding = TaggedObject "mode" "settings"
}''UploadMode
derivePersistFieldJSON ''UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
@ -300,20 +313,51 @@ instance PathPiece UploadMode where
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
data SubmissionMode = SubmissionMode
{ submissionModeCorrector :: Bool
, submissionModeUser :: Maybe UploadMode
}
deriving (Show, Read, Eq, Ord, Generic)
deriveFinite ''SubmissionMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
{ fieldLabelModifier = camelToPathPiece' 2
} ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
finitePathPiece ''SubmissionMode
[ "no-submissions"
, "no-upload"
, "no-unpack"
, "unpack"
, "correctors"
, "correctors+no-upload"
, "correctors+no-unpack"
, "correctors+unpack"
]
data SubmissionModeDescr = SubmissionModeNone
| SubmissionModeCorrector
| SubmissionModeUser
| SubmissionModeBoth
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr
finitePathPiece ''SubmissionModeDescr
[ "no-submissions"
, "correctors"
, "users"
, "correctors+users"
]
classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
@ -329,6 +373,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Hashable Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@ -526,9 +571,11 @@ deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
} ''CorrectorState
instance Universe CorrectorState where universe = universeDef
instance Universe CorrectorState
instance Finite CorrectorState
instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState"
@ -714,7 +761,9 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
= AuthAdmin
| AuthLecturer
| AuthCorrector
| AuthRegistered
| AuthTutor
| AuthCourseRegistered
| AuthTutorialRegistered
| AuthParticipant
| AuthTime
| AuthMaterials
@ -723,15 +772,18 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthUserSubmissions
| AuthCorrectorSubmissions
| AuthCapacity
| AuthRegisterGroup
| AuthEmpty
| AuthSelf
| AuthAuthentication
| AuthNoEscalation
| AuthRead
| AuthWrite
| AuthToken
| AuthDeprecated
| AuthDevelopment
| AuthFree
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AuthTag
instance Finite AuthTag
@ -749,6 +801,8 @@ instance ToJSONKey AuthTag where
instance FromJSONKey AuthTag where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
instance Binary AuthTag
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
deriving (Read, Show, Generic)
@ -772,6 +826,45 @@ instance FromJSON AuthTagActive where
derivePersistFieldJSON ''AuthTagActive
data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Hashable a => Hashable (PredLiteral a)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = ObjectWithSingleField
, unwrapUnaryRecords = True
} ''PredLiteral
instance PathPiece a => PathPiece (PredLiteral a) where
toPathPiece PLVariable{..} = toPathPiece plVar
toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
fromPathPiece t = PLVariable <$> fromPathPiece t
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
instance Binary a => Binary (PredLiteral a)
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Semigroup, Monoid)
$(return [])
instance ToJSON a => ToJSON (PredDNF a) where
toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
instance (Ord a, Binary a) => Binary (PredDNF a) where
get = PredDNF <$> Binary.get
put = Binary.put . dnfTerms
type AuthLiteral = PredLiteral AuthTag
type AuthDNF = PredDNF AuthTag
data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@ -785,6 +878,102 @@ deriveJSON defaultOptions
} ''LecturerType
derivePersistFieldJSON ''LecturerType
instance Hashable LecturerType
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''WeekDay
data OccurenceSchedule = ScheduleWeekly
{ scheduleDayOfWeek :: WeekDay
, scheduleStart :: TimeOfDay
, scheduleEnd :: TimeOfDay
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "repeat" "schedule"
} ''OccurenceSchedule
data OccurenceException = ExceptOccur
{ exceptDay :: Day
, exceptStart :: TimeOfDay
, exceptEnd :: TimeOfDay
}
| ExceptNoOccur
{ exceptTime :: LocalTime
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, constructorTagModifier = camelToPathPiece' 1
, sumEncoding = TaggedObject "exception" "for"
} ''OccurenceException
data Occurences = Occurences
{ occurencesScheduled :: Set OccurenceSchedule
, occurencesExceptions :: Set OccurenceException
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''Occurences
derivePersistFieldJSON ''Occurences
data HealthReport = HealthReport
{ healthMatchingClusterConfig :: Bool
-- ^ Is the database-stored configuration we're running under still up to date?
, healthHTTPReachable :: Maybe Bool
-- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
--
-- Can be `Nothing` if we don't have a static configuration setting `appRoot` or if check is disabled in settings
, healthLDAPAdmins :: Maybe Rational
-- ^ Proportion of school admins that could be found in LDAP
--
-- Is `Nothing` if LDAP is not configured or no users are school admins
, healthSMTPConnect :: Maybe Bool
-- ^ Can we connect to the SMTP server and say @NOOP@?
, healthWidgetMemcached :: Maybe Bool
-- ^ Can we store values in memcached and retrieve them via HTTP?
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
, omitNothingFields = True
} ''HealthReport
-- | `HealthReport` classified (`classifyHealthReport`) by badness
--
-- > a < b = a `worseThan` b
--
-- Currently all consumers of this type check for @(== HealthSuccess)@; this
-- needs to be adjusted on a case-by-case basis if new constructors are added
data HealthStatus = HealthFailure | HealthSuccess
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe HealthStatus
instance Finite HealthStatus
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''HealthStatus
nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
classifyHealthReport :: HealthReport -> HealthStatus
-- ^ Classify `HealthReport` by badness
classifyHealthReport HealthReport{..} = getMin . execWriter $ do -- Construction with `Writer (Min HealthStatus) a` returns worst `HealthStatus` passed to `tell` at any point
unless healthMatchingClusterConfig . tell $ Min HealthFailure
unless (fromMaybe True healthHTTPReachable) . tell $ Min HealthFailure
unless (maybe True (> 0) healthLDAPAdmins) . tell $ Min HealthFailure
unless (fromMaybe True healthSMTPConnect) . tell $ Min HealthFailure
unless (fromMaybe True healthWidgetMemcached) . tell $ Min HealthFailure
-- Type synonyms
@ -795,8 +984,12 @@ type SchoolShorthand = CI Text
type CourseName = CI Text
type CourseShorthand = CI Text
type SheetName = CI Text
type MaterialName = CI Text
type UserEmail = CI Email
type TutorialName = CI Text
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID
type ClusterId = UUID
type TokenId = UUID
type TermCandidateIncidence = UUID

23
src/Model/Types/JSON.hs
View File

@ -1,5 +1,6 @@
module Model.Types.JSON
( derivePersistFieldJSON
, predNFAesonOptions
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@ -9,11 +10,13 @@ import Database.Persist.Sql
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Encoding as Text
import qualified Data.Aeson as JSON
import Data.Aeson as JSON
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Utils.PathPiece
derivePersistFieldJSON :: Name -> DecsQ
derivePersistFieldJSON tName = do
@ -28,10 +31,10 @@ derivePersistFieldJSON tName = do
| otherwise = cxt [[t|PersistField|] `appT` t]
sequence
[ instanceD iCxt ([t|PersistField|] `appT` t)
[ funD (mkName "toPersistValue")
[ funD 'toPersistValue
[ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
]
, funD (mkName "fromPersistValue")
, funD 'fromPersistValue
[ do
bs <- newName "bs"
clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@ -45,8 +48,20 @@ derivePersistFieldJSON tName = do
]
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD (mkName "sqlType")
[ funD 'sqlType
[ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
]
]
]
predNFAesonOptions :: Options
-- ^ Needed for JSON instances of `predCNF` and `predDNF`
--
-- Moved to this module due to stage restriction
predNFAesonOptions = defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = ObjectWithSingleField
, tagSingleConstructors = True
}

91
src/Settings.hs
View File

@ -21,12 +21,18 @@ import Data.Aeson.TH
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf)
import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Wai.Handler.Warp (HostPreference)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
#ifdef DEVELOPMENT
import Yesod.Default.Util (WidgetFileSettings, widgetFileReload)
import Language.Haskell.TH.Syntax (Exp, Q, location, Loc(..))
import Text.Shakespeare.Text (st)
import Text.Blaze.Html (preEscapedToHtml)
#else
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload)
import Language.Haskell.TH.Syntax (Exp, Q)
#endif
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Data.Time (NominalDiffTime, nominalDay)
@ -42,9 +48,6 @@ import qualified Ldap.Client as Ldap
import Utils hiding (MessageStatus(..))
import Control.Lens
import Data.Maybe (fromJust)
import qualified Data.Char as Char
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
import qualified Network
@ -63,6 +66,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import qualified System.FilePath as FilePath
import Jose.Jwt (JwtEncoding(..))
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
@ -100,6 +106,12 @@ data AppSettings = AppSettings
, appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime
, appMaximumContentLength :: Maybe Word64
, appJwtExpiration :: Maybe NominalDiffTime
, appJwtEncoding :: JwtEncoding
, appHealthCheckInterval :: NominalDiffTime
, appHealthCheckHTTP :: Bool
, appHealthCheckDelayNotify :: Bool
, appInitialLogSettings :: LogSettings
@ -267,7 +279,7 @@ deriveFromJSON
deriveJSON
defaultOptions
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = UntaggedValue
}
''LogLevel
@ -310,6 +322,18 @@ deriveFromJSON
}
''SmtpAuthConf
instance FromJSON JwtEncoding where
parseJSON v@(String _) = JwsEncoding <$> parseJSON v
parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
[ do
alg <- obj .: "alg"
return $ JwsEncoding alg
, do
alg <- obj .: "alg"
enc <- obj .: "enc"
return $ JweEncoding alg enc
]
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
@ -352,6 +376,12 @@ instance FromJSON AppSettings where
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
appJwtExpiration <- o .:? "jwt-expiration"
appJwtEncoding <- o .: "jwt-encoding"
appHealthCheckInterval <- o .: "health-check-interval"
appHealthCheckHTTP <- o .: "health-check-http"
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
appSessionTimeout <- o .: "session-timeout"
@ -379,6 +409,8 @@ instance FromJSON AppSettings where
return AppSettings {..}
makeClassy_ ''AppSettings
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
@ -388,18 +420,29 @@ instance FromJSON AppSettings where
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
-- | How static files should be combined.
combineSettings :: CombineSettings
combineSettings = def
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = (if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
#ifdef DEVELOPMENT
widgetFile nameBase = do
Loc{..} <- location
let nameBase' = "templates" </> nameBase
before, after :: Text
before = [st|<!-- BEGIN ‘#{nameBase'}.*’ IN ‘#{loc_filename}’ #{tshow loc_start}–#{tshow loc_end} -->|]
after = [st|<!-- END ‘#{nameBase'}.*’ -->|]
[e| do
toWidget $ preEscapedToHtml before
$(widgetFileReload widgetFileSettings nameBase)
toWidget $ preEscapedToHtml after
|]
#else
widgetFile
| appReloadTemplates compileTimeAppSettings
= widgetFileReload widgetFileSettings
| otherwise
= widgetFileNoReload widgetFileSettings
#endif
-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
@ -416,19 +459,3 @@ compileTimeAppSettings =
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Error e -> error e
Success settings -> settings
-- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets'
(appSkipCombining compileTimeAppSettings)
combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts'
(appSkipCombining compileTimeAppSettings)
combineSettings

24
src/Settings/Cluster.hs
View File

@ -32,11 +32,20 @@ import qualified Data.Binary as Binary
import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Base64.URL as Base64
import qualified Jose.Jwa as Jose
import qualified Jose.Jwk as Jose
import qualified Jose.Jwt as Jose
import Data.UUID (UUID)
import Control.Monad.Random.Class (MonadRandom(..))
data ClusterSettingsKey
= ClusterCryptoIDKey
| ClusterClientSessionKey
| ClusterSecretBoxKey
| ClusterJSONWebKeySet
| ClusterId
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ClusterSettingsKey
@ -120,3 +129,18 @@ instance FromJSON SecretBox.Key where
parseJSON = Aeson.withText "Key" $ \t -> do
bytes <- either fail return . Base64.decode $ encodeUtf8 t
maybe (fail "Could not parse key") return $ Saltine.decode bytes
instance ClusterSetting 'ClusterJSONWebKeySet where
type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
initClusterSetting _ = liftIO $ do
now <- getCurrentTime
jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
return $ Jose.JwkSet [jwkSig]
knownClusterSetting _ = ClusterJSONWebKeySet
instance ClusterSetting 'ClusterId where
type ClusterSettingValue 'ClusterId = UUID
initClusterSetting _ = liftIO getRandom
knownClusterSetting _ = ClusterId

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