Merge branch 'master' into 'live'
Master Closes #259 and #253 See merge request !122
This commit is contained in:
Gregor Kleen
commit
bf50ceef8f
168
README.md
168
README.md
@ -1,168 +0,0 @@
|
|||||||
# Quick Start Guide
|
|
||||||
|
|
||||||
The following Description applies to Ubuntu or similar.
|
|
||||||
|
|
||||||
## Clone repository
|
|
||||||
Clone this repository and navigate into
|
|
||||||
```sh
|
|
||||||
$ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX
|
|
||||||
```
|
|
||||||
|
|
||||||
## LDAP
|
|
||||||
install:
|
|
||||||
```sh
|
|
||||||
$ sudo apt-get install slapd ldap-utils
|
|
||||||
```
|
|
||||||
|
|
||||||
|
|
||||||
## PostgreSQL
|
|
||||||
install:
|
|
||||||
```sh
|
|
||||||
$ sudo apt-get install postgresql
|
|
||||||
```
|
|
||||||
|
|
||||||
switch to user *postgres* (got created during installation):
|
|
||||||
```sh
|
|
||||||
$ sudo -i -u postgres
|
|
||||||
```
|
|
||||||
|
|
||||||
add db user *uniworx*:
|
|
||||||
```sh
|
|
||||||
$ createuser --interactive
|
|
||||||
```
|
|
||||||
|
|
||||||
you'll get a prompt:
|
|
||||||
|
|
||||||
```sh
|
|
||||||
Enter name of role to add:` - uniworx
|
|
||||||
Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
|
|
||||||
Password: uniworx
|
|
||||||
...
|
|
||||||
```
|
|
||||||
|
|
||||||
create database *uniworx*:
|
|
||||||
```sh
|
|
||||||
$ createdb uniworx
|
|
||||||
```
|
|
||||||
|
|
||||||
after you added the database switch back to your own user with `Ctrl + D`.
|
|
||||||
|
|
||||||
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
|
|
||||||
```sh
|
|
||||||
$ sudo adduser uniworx
|
|
||||||
```
|
|
||||||
|
|
||||||
log-in as new user *uniworx*:
|
|
||||||
```sh
|
|
||||||
$ sudo -i -u uniworx
|
|
||||||
```
|
|
||||||
|
|
||||||
you can now use
|
|
||||||
```sh
|
|
||||||
$ psql uniworx
|
|
||||||
```
|
|
||||||
to execute SQL-commands and such.
|
|
||||||
|
|
||||||
## stack
|
|
||||||
Install with:
|
|
||||||
```sh
|
|
||||||
$ curl -sSL https://get.haskellstack.org/ | sh
|
|
||||||
```
|
|
||||||
|
|
||||||
setup stack and install dependencies:
|
|
||||||
```sh
|
|
||||||
$ stack setup
|
|
||||||
```
|
|
||||||
|
|
||||||
During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
|
|
||||||
```sh
|
|
||||||
$ sudo apt-get install libsasl2-dev libldap2-dev
|
|
||||||
```
|
|
||||||
|
|
||||||
If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
|
|
||||||
Go ahead an install `libpq-dev` with
|
|
||||||
```sh
|
|
||||||
$ sudo apt-get install libpq-dev
|
|
||||||
```
|
|
||||||
|
|
||||||
Other packages you might need to install during this process:
|
|
||||||
```sh
|
|
||||||
$ sudo apt-get install pkg-config
|
|
||||||
sudo apt-get install libsodium-dev
|
|
||||||
```
|
|
||||||
|
|
||||||
Build the app:
|
|
||||||
```sh
|
|
||||||
$ stack build
|
|
||||||
```
|
|
||||||
|
|
||||||
This might take a few minutes if not hours... be prepared.
|
|
||||||
|
|
||||||
install yesod:
|
|
||||||
```sh
|
|
||||||
$ stack install yesod-bin --install-ghc
|
|
||||||
```
|
|
||||||
|
|
||||||
## Add Dumy-Data and run the app
|
|
||||||
After building the app you can prepare the database and add some dummy data:
|
|
||||||
```sh
|
|
||||||
$ ./db.sh -f
|
|
||||||
```
|
|
||||||
|
|
||||||
Run the app:
|
|
||||||
```sh
|
|
||||||
$ ./start.sh
|
|
||||||
...
|
|
||||||
Devel application launched: http://localhost:3000
|
|
||||||
```
|
|
||||||
|
|
||||||
If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
|
|
||||||
|
|
||||||
***
|
|
||||||
|
|
||||||
# Sources and more infos
|
|
||||||
PostgreSQl:
|
|
||||||
https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04
|
|
||||||
|
|
||||||
stack: https://docs.haskellstack.org/en/stable/README/#how-to-install
|
|
||||||
|
|
||||||
ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/
|
|
||||||
|
|
||||||
|
|
||||||
Instead of run.sh, use:
|
|
||||||
stack build --flag uniworx:dev --flag uniworx:library-only
|
|
||||||
|
|
||||||
|
|
||||||
***
|
|
||||||
|
|
||||||
# PostgreSQL
|
|
||||||
|
|
||||||
Starten als Root:
|
|
||||||
|
|
||||||
# systemctl start postgresql
|
|
||||||
# find / -name postgresql.conf
|
|
||||||
# cd /var/lib/pgsql/data/
|
|
||||||
# su - postgres
|
|
||||||
|
|
||||||
|
|
||||||
psql -U uniworx -d uniworx -h 127.0.0.1 -w
|
|
||||||
|
|
||||||
--Zeige Tabellen
|
|
||||||
\dt
|
|
||||||
|
|
||||||
--Zeige Tabellen Inhalt:
|
|
||||||
TABLE "user";
|
|
||||||
-- Die Anführungszeichen können manchmal weggelassen werden, aber
|
|
||||||
-- bei user sind sie notwendig, da es auch Schlüsselwort in sql ist.
|
|
||||||
|
|
||||||
--Lösche Tabelle "course" und alle davon abhängigen:
|
|
||||||
DROP TABLE "course" CASCADE;
|
|
||||||
|
|
||||||
-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
|
|
||||||
INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1);
|
|
||||||
|
|
||||||
-- Beenden:
|
|
||||||
\q
|
|
||||||
|
|
||||||
-- Hilfe:
|
|
||||||
\help
|
|
||||||
@ -27,7 +27,10 @@ stanzas:
|
|||||||
- LDAPPASS
|
- LDAPPASS
|
||||||
- LDAPBASE
|
- LDAPBASE
|
||||||
- LDAPSCOPE
|
- LDAPSCOPE
|
||||||
|
- LDAPSEARCHTIME
|
||||||
|
- LDAPSTRIPES
|
||||||
- LDAPTIMEOUT
|
- LDAPTIMEOUT
|
||||||
|
- LDAPLIMIT
|
||||||
- DUMMY_LOGIN
|
- DUMMY_LOGIN
|
||||||
- DETAILED_LOGGING
|
- DETAILED_LOGGING
|
||||||
- LOG_ALL
|
- LOG_ALL
|
||||||
@ -46,6 +49,8 @@ stanzas:
|
|||||||
- SMTPPASS
|
- SMTPPASS
|
||||||
- SMTPTIMEOUT
|
- SMTPTIMEOUT
|
||||||
- SMTPLIMIT
|
- SMTPLIMIT
|
||||||
|
- MAILSUPPORT
|
||||||
|
- MAILSUPPORT_NAME
|
||||||
- INSTANCE_ID
|
- INSTANCE_ID
|
||||||
- MEMCACHEDHOST
|
- MEMCACHEDHOST
|
||||||
- MEMCACHEDPORT
|
- MEMCACHEDPORT
|
||||||
|
|||||||
@ -27,7 +27,10 @@ stanzas:
|
|||||||
- LDAPPASS
|
- LDAPPASS
|
||||||
- LDAPBASE
|
- LDAPBASE
|
||||||
- LDAPSCOPE
|
- LDAPSCOPE
|
||||||
|
- LDAPSEARCHTIME
|
||||||
|
- LDAPSTRIPES
|
||||||
- LDAPTIMEOUT
|
- LDAPTIMEOUT
|
||||||
|
- LDAPLIMIT
|
||||||
- DETAILED_LOGGING
|
- DETAILED_LOGGING
|
||||||
- LOG_ALL
|
- LOG_ALL
|
||||||
- LOGLEVEL
|
- LOGLEVEL
|
||||||
@ -45,6 +48,8 @@ stanzas:
|
|||||||
- SMTPPASS
|
- SMTPPASS
|
||||||
- SMTPTIMEOUT
|
- SMTPTIMEOUT
|
||||||
- SMTPLIMIT
|
- SMTPLIMIT
|
||||||
|
- MAILSUPPORT
|
||||||
|
- MAILSUPPORT_NAME
|
||||||
- INSTANCE_ID
|
- INSTANCE_ID
|
||||||
- MEMCACHEDHOST
|
- MEMCACHEDHOST
|
||||||
- MEMCACHEDPORT
|
- MEMCACHEDPORT
|
||||||
|
|||||||
@ -16,8 +16,8 @@ mail-verp:
|
|||||||
separator: "+"
|
separator: "+"
|
||||||
at-replacement: "="
|
at-replacement: "="
|
||||||
mail-support:
|
mail-support:
|
||||||
name: null
|
name: "_env:MAILSUPPORT_NAME:"
|
||||||
email: "uni2work@ifi.lmu.de"
|
email: "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
|
||||||
|
|
||||||
job-workers: "_env:JOB_WORKERS:10"
|
job-workers: "_env:JOB_WORKERS:10"
|
||||||
job-flush-interval: "_env:JOB_FLUSH:30"
|
job-flush-interval: "_env:JOB_FLUSH:30"
|
||||||
@ -66,7 +66,11 @@ ldap:
|
|||||||
pass: "_env:LDAPPASS:"
|
pass: "_env:LDAPPASS:"
|
||||||
baseDN: "_env:LDAPBASE:"
|
baseDN: "_env:LDAPBASE:"
|
||||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||||
timeout: "_env:LDAPTIMEOUT:5"
|
timeout: "_env:LDAPSEARCHTIME:5"
|
||||||
|
pool:
|
||||||
|
stripes: "_env:LDAPSTRIPES:1"
|
||||||
|
timeout: "_env:LDAPTIMEOUT:20"
|
||||||
|
limit: "_env:LDAPLIMIT:10"
|
||||||
|
|
||||||
smtp:
|
smtp:
|
||||||
host: "_env:SMTPHOST:"
|
host: "_env:SMTPHOST:"
|
||||||
|
|||||||
3
messages/button/de.msg
Normal file
3
messages/button/de.msg
Normal file
@ -0,0 +1,3 @@
|
|||||||
|
AmbiguousButtons: Mehrere Submit-Buttons aktiv
|
||||||
|
WrongButtonValue: Submit-Button hat falschen Wert
|
||||||
|
MultipleButtonValues: Submit-Button hat mehrere Werte
|
||||||
@ -1 +1,2 @@
|
|||||||
DummyIdent: Nutzer-Kennung
|
DummyIdent: Nutzer-Kennung
|
||||||
|
DummyNoFormData: Keine Formulardaten empfangen
|
||||||
@ -69,9 +69,13 @@ CourseSemester: Semester
|
|||||||
CourseSchool: Institut
|
CourseSchool: Institut
|
||||||
CourseSchoolShort: Fach
|
CourseSchoolShort: Fach
|
||||||
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
|
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
|
||||||
CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
|
CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden möglich
|
||||||
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
|
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
|
||||||
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
|
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
|
||||||
|
CourseFilterSearch: Volltext-Suche
|
||||||
|
CourseFilterRegistered: Registriert
|
||||||
|
CourseDeleteQuestion: Wollen Sie den unten aufgeführten Kurs wirklich löschen?
|
||||||
|
CourseDeleted: Kurs gelöscht
|
||||||
|
|
||||||
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
|
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
|
||||||
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
|
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
|
||||||
@ -87,9 +91,12 @@ SheetTitleNew tid@TermId ssh@SchoolId csh@CourseShorthand
|
|||||||
SheetEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
|
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.
|
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}.
|
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?
|
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!
|
||||||
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
|
|
||||||
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
|
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"}!
|
||||||
|
|
||||||
|
SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
|
||||||
|
SheetDeleted: Übungsblatt gelöscht
|
||||||
|
|
||||||
SheetUploadMode: Abgabe von Dateien
|
SheetUploadMode: Abgabe von Dateien
|
||||||
SheetSubmissionMode: Abgabe-Modus
|
SheetSubmissionMode: Abgabe-Modus
|
||||||
@ -138,6 +145,9 @@ SubmissionFile: Datei zur Abgabe
|
|||||||
SubmissionFiles: Abgegebene Dateien
|
SubmissionFiles: Abgegebene Dateien
|
||||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||||
|
|
||||||
|
SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
|
||||||
|
SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
|
||||||
|
|
||||||
SubmissionGroupName: Gruppenname
|
SubmissionGroupName: Gruppenname
|
||||||
|
|
||||||
CorrectionsTitle: Zugewiesene Korrekturen
|
CorrectionsTitle: Zugewiesene Korrekturen
|
||||||
@ -151,6 +161,7 @@ UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
|
|||||||
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
|
||||||
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
|
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
|
||||||
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
|
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.
|
||||||
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
|
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
|
||||||
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
|
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
|
||||||
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
|
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
|
||||||
@ -184,6 +195,7 @@ AddCorrector: Zusätzlicher Korrektor
|
|||||||
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
||||||
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
|
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
|
||||||
CountTutProp: Tutorien zählen gegen Proportion
|
CountTutProp: Tutorien zählen gegen Proportion
|
||||||
|
AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
|
||||||
Corrector: Korrektor
|
Corrector: Korrektor
|
||||||
Correctors: Korrektoren
|
Correctors: Korrektoren
|
||||||
CorState: Status
|
CorState: Status
|
||||||
@ -226,13 +238,18 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
|
|||||||
|
|
||||||
NrColumn: Nr
|
NrColumn: Nr
|
||||||
SelectColumn: Auswahl
|
SelectColumn: Auswahl
|
||||||
|
DBTablePagesize: Einträge
|
||||||
|
DBTablePagesizeAll: Alle
|
||||||
|
|
||||||
CorrDownload: Herunterladen
|
CorrDownload: Herunterladen
|
||||||
CorrUploadField: Korrekturen
|
CorrUploadField: Korrekturen
|
||||||
CorrUpload: Korrekturen hochladen
|
CorrUpload: Korrekturen hochladen
|
||||||
CorrSetCorrector: Korrektor zuweisen
|
CorrSetCorrector: Korrektor zuweisen
|
||||||
CorrAutoSetCorrector: Korrekturen verteilen
|
CorrAutoSetCorrector: Korrekturen verteilen
|
||||||
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
|
CorrDelete: Abgaben löschen
|
||||||
|
NatField name@Text: #{name} muss eine natürliche Zahl sein!
|
||||||
|
JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure}
|
||||||
|
SecretJSONFieldDecryptFailure: Konnte versteckte vertrauliche Daten nicht entschlüsseln
|
||||||
|
|
||||||
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
||||||
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
|
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
|
||||||
@ -292,6 +309,13 @@ RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl
|
|||||||
RatingNotExpected: Keine Bewertungen erlaubt
|
RatingNotExpected: Keine Bewertungen erlaubt
|
||||||
RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
|
RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein
|
||||||
|
|
||||||
|
SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor
|
||||||
|
SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
|
||||||
|
SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
|
||||||
|
SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
|
||||||
|
|
||||||
|
MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
|
||||||
|
|
||||||
NoTableContent: Kein Tabelleninhalt
|
NoTableContent: Kein Tabelleninhalt
|
||||||
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
|
||||||
|
|
||||||
@ -366,11 +390,17 @@ MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{co
|
|||||||
MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
|
MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
|
||||||
MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
|
MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
|
||||||
|
|
||||||
|
MailSubjectSubmissionsUnassigned csh@CourseShorthand sheetName@SheetName: Abgaben zu #{sheetName} in #{csh} konnten nicht verteilt werden
|
||||||
|
MailSubmissionsUnassignedIntro n@Int courseName@Text termDesc@Text sheetName@SheetName: #{tshow n} Abgaben zu #{sheetName} im Kurs #{courseName} (#{termDesc}) konnten nicht automatisiert verteilt werden.
|
||||||
|
|
||||||
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
|
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.
|
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: Abgabfrist für #{sheetName} in #{csh} abgelaufen
|
||||||
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
|
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
|
||||||
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
|
|
||||||
|
MailSubjectCorrectionsAssigned csh@CourseShorthand sheetName@SheetName: Ihnen wurden Korrekturen zu #{sheetName} in #{csh} zugeteilt
|
||||||
|
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} #{pluralDE n "Abgabe wurde" "Abgaben wurden"} Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
|
||||||
|
|
||||||
MailEditNotifications: Benachrichtigungen ein-/ausschalten
|
MailEditNotifications: Benachrichtigungen ein-/ausschalten
|
||||||
MailSubjectSupport: Supportanfrage
|
MailSubjectSupport: Supportanfrage
|
||||||
|
|
||||||
@ -390,11 +420,12 @@ SheetTypeBonus grading@SheetGrading: Bonus
|
|||||||
SheetTypeNormal grading@SheetGrading: Normal
|
SheetTypeNormal grading@SheetGrading: Normal
|
||||||
SheetTypeInformational grading@SheetGrading: Keine Wertung
|
SheetTypeInformational grading@SheetGrading: Keine Wertung
|
||||||
SheetTypeNotGraded: Unbewertet
|
SheetTypeNotGraded: Unbewertet
|
||||||
|
SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information der Teilnehmer.
|
||||||
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
|
SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter.
|
||||||
SheetTypeInfoNotGraded: Blätter ohne Wertung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information an die Teilnehmer.
|
|
||||||
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
|
SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt.
|
||||||
SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
|
SummaryTitle: Zusammenfassung über
|
||||||
SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
|
SheetGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Blatt" "Blätter"}
|
||||||
|
SubmissionGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Abgabe" "Abgaben"}
|
||||||
|
|
||||||
SheetTypeBonus': Bonus
|
SheetTypeBonus': Bonus
|
||||||
SheetTypeNormal': Normal
|
SheetTypeNormal': Normal
|
||||||
@ -417,6 +448,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
|
|||||||
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
|
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
|
||||||
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
|
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
|
||||||
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
|
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
|
||||||
|
NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
|
||||||
|
|
||||||
CorrCreate: Abgaben erstellen
|
CorrCreate: Abgaben erstellen
|
||||||
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
|
||||||
@ -518,6 +550,7 @@ MenuLogout: Logout
|
|||||||
MenuCourseList: Kurse
|
MenuCourseList: Kurse
|
||||||
MenuTermShow: Semester
|
MenuTermShow: Semester
|
||||||
MenuCorrection: Korrektur
|
MenuCorrection: Korrektur
|
||||||
|
MenuSubmissionDelete: Abgabe löschen
|
||||||
MenuUsers: Benutzer
|
MenuUsers: Benutzer
|
||||||
MenuAdminTest: Admin-Demo
|
MenuAdminTest: Admin-Demo
|
||||||
MenuMessageList: Systemnachrichten
|
MenuMessageList: Systemnachrichten
|
||||||
@ -531,18 +564,21 @@ MenuCorrections: Abgaben
|
|||||||
MenuSheetNew: Neues Übungsblatt anlegen
|
MenuSheetNew: Neues Übungsblatt anlegen
|
||||||
MenuCourseEdit: Kurs editieren
|
MenuCourseEdit: Kurs editieren
|
||||||
MenuCourseNewTemplate: Als neuen Kurs klonen
|
MenuCourseNewTemplate: Als neuen Kurs klonen
|
||||||
|
MenuCourseDelete: Kurs löschen
|
||||||
MenuSubmissionNew: Abgabe anlegen
|
MenuSubmissionNew: Abgabe anlegen
|
||||||
MenuSubmissionOwn: Abgabe
|
MenuSubmissionOwn: Abgabe
|
||||||
MenuCorrectors: Korrektoren
|
MenuCorrectors: Korrektoren
|
||||||
MenuSheetEdit: Übungsblatt editieren
|
MenuSheetEdit: Übungsblatt editieren
|
||||||
|
MenuSheetDelete: Übungsblatt löschen
|
||||||
MenuCorrectionsUpload: Korrekturen hochladen
|
MenuCorrectionsUpload: Korrekturen hochladen
|
||||||
MenuCorrectionsCreate: Abgaben registrieren
|
MenuCorrectionsCreate: Abgaben registrieren
|
||||||
MenuCorrectionsGrade: Abgaben bewerten
|
MenuCorrectionsGrade: Abgaben bewerten
|
||||||
|
|
||||||
AuthPredsActive: Aktive Authorisierungsprädikate
|
AuthPredsActive: Aktive Authorisierungsprädikate
|
||||||
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
|
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
|
||||||
AuthTagFree: Seite ist generell zugänglich
|
AuthTagFree: Seite ist universell zugänglich
|
||||||
AuthTagAdmin: Nutzer ist Administrator
|
AuthTagAdmin: Nutzer ist Administrator
|
||||||
|
AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
|
||||||
AuthTagDeprecated: Seite ist nicht überholt
|
AuthTagDeprecated: Seite ist nicht überholt
|
||||||
AuthTagDevelopment: Seite ist nicht in Entwicklung
|
AuthTagDevelopment: Seite ist nicht in Entwicklung
|
||||||
AuthTagLecturer: Nutzer ist Dozent
|
AuthTagLecturer: Nutzer ist Dozent
|
||||||
@ -559,3 +595,7 @@ AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
|
|||||||
AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
|
AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
|
||||||
AuthTagRead: Zugriff ist nur lesend
|
AuthTagRead: Zugriff ist nur lesend
|
||||||
AuthTagWrite: Zugriff ist i.A. schreibend
|
AuthTagWrite: Zugriff ist i.A. schreibend
|
||||||
|
|
||||||
|
DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "das obige Objekt" "obige Objekte"} unwiderbringlich löschen möchten, schreiben Sie bitte zunächst den angezeigten Text ab.
|
||||||
|
DeleteConfirmation: Bestätigung
|
||||||
|
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
|
||||||
262
models
262
models
@ -1,262 +0,0 @@
|
|||||||
User json
|
|
||||||
ident (CI Text)
|
|
||||||
authentication AuthenticationMode
|
|
||||||
matrikelnummer Text Maybe
|
|
||||||
email (CI Text)
|
|
||||||
displayName Text
|
|
||||||
surname Text -- always use: nameWidget displayName surname
|
|
||||||
maxFavourites Int default=12
|
|
||||||
theme Theme default='Default'
|
|
||||||
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
|
|
||||||
dateFormat DateTimeFormat "default='%d.%m.%Y'"
|
|
||||||
timeFormat DateTimeFormat "default='%R'"
|
|
||||||
downloadFiles Bool default=false
|
|
||||||
mailLanguages MailLanguages default='[]'
|
|
||||||
notificationSettings NotificationSettings
|
|
||||||
UniqueAuthentication ident
|
|
||||||
UniqueEmail email
|
|
||||||
deriving Show Eq
|
|
||||||
UserAdmin
|
|
||||||
user UserId
|
|
||||||
school SchoolId
|
|
||||||
UniqueUserAdmin user school
|
|
||||||
UserLecturer
|
|
||||||
user UserId
|
|
||||||
school SchoolId
|
|
||||||
UniqueSchoolLecturer user school
|
|
||||||
StudyFeatures
|
|
||||||
user UserId
|
|
||||||
degree StudyDegreeId
|
|
||||||
field StudyTermsId
|
|
||||||
type StudyFieldType
|
|
||||||
semester Int
|
|
||||||
-- UniqueUserSubject user degree field -- There exists a counterexample
|
|
||||||
StudyDegree
|
|
||||||
key Int
|
|
||||||
shorthand Text Maybe
|
|
||||||
name Text Maybe
|
|
||||||
Primary key
|
|
||||||
StudyTerms
|
|
||||||
key Int
|
|
||||||
shorthand Text Maybe
|
|
||||||
name Text Maybe
|
|
||||||
Primary key
|
|
||||||
Term json
|
|
||||||
name TermIdentifier -- unTermKey :: TermId -> TermIdentifier
|
|
||||||
start Day -- TermKey :: TermIdentifier -> TermId
|
|
||||||
end Day
|
|
||||||
holidays [Day]
|
|
||||||
lectureStart Day
|
|
||||||
lectureEnd Day
|
|
||||||
active Bool
|
|
||||||
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
|
|
||||||
deriving Show -- type TermId = Key Term
|
|
||||||
School json
|
|
||||||
name (CI Text)
|
|
||||||
shorthand (CI Text)
|
|
||||||
UniqueSchool name
|
|
||||||
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
|
|
||||||
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
|
|
||||||
deriving Eq
|
|
||||||
DegreeCourse json
|
|
||||||
course CourseId
|
|
||||||
degree StudyDegreeId
|
|
||||||
terms StudyTermsId
|
|
||||||
UniqueDegreeCourse course degree terms
|
|
||||||
Course
|
|
||||||
name (CI Text)
|
|
||||||
description Html Maybe
|
|
||||||
linkExternal Text Maybe
|
|
||||||
shorthand (CI Text)
|
|
||||||
term TermId
|
|
||||||
school SchoolId
|
|
||||||
capacity Int64 Maybe
|
|
||||||
-- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
|
|
||||||
registerFrom UTCTime Maybe
|
|
||||||
registerTo UTCTime Maybe
|
|
||||||
deregisterUntil UTCTime Maybe
|
|
||||||
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
|
||||||
materialFree Bool
|
|
||||||
TermSchoolCourseShort term school shorthand
|
|
||||||
TermSchoolCourseName term school name
|
|
||||||
CourseEdit
|
|
||||||
user UserId
|
|
||||||
time UTCTime
|
|
||||||
course CourseId
|
|
||||||
CourseFavourite
|
|
||||||
user UserId
|
|
||||||
time UTCTime
|
|
||||||
course CourseId
|
|
||||||
UniqueCourseFavourite user course
|
|
||||||
deriving Show
|
|
||||||
Lecturer
|
|
||||||
user UserId
|
|
||||||
course CourseId
|
|
||||||
UniqueLecturer user course
|
|
||||||
CourseParticipant
|
|
||||||
course CourseId
|
|
||||||
user UserId
|
|
||||||
registration UTCTime
|
|
||||||
UniqueParticipant user course
|
|
||||||
Sheet
|
|
||||||
course CourseId
|
|
||||||
name (CI Text)
|
|
||||||
description Html Maybe
|
|
||||||
type SheetType
|
|
||||||
grouping SheetGroup
|
|
||||||
markingText Html Maybe
|
|
||||||
visibleFrom UTCTime Maybe
|
|
||||||
activeFrom UTCTime
|
|
||||||
activeTo UTCTime
|
|
||||||
hintFrom UTCTime Maybe
|
|
||||||
solutionFrom UTCTime Maybe
|
|
||||||
uploadMode UploadMode
|
|
||||||
submissionMode SheetSubmissionMode default='UserSubmissions'
|
|
||||||
CourseSheet course name
|
|
||||||
SheetEdit
|
|
||||||
user UserId
|
|
||||||
time UTCTime
|
|
||||||
sheet SheetId
|
|
||||||
SheetPseudonym
|
|
||||||
sheet SheetId
|
|
||||||
pseudonym Pseudonym
|
|
||||||
user UserId
|
|
||||||
UniqueSheetPseudonym sheet pseudonym
|
|
||||||
UniqueSheetPseudonymUser sheet user
|
|
||||||
SheetCorrector
|
|
||||||
user UserId
|
|
||||||
sheet SheetId
|
|
||||||
load Load
|
|
||||||
state CorrectorState default='CorrectorNormal'
|
|
||||||
UniqueSheetCorrector user sheet
|
|
||||||
deriving Show Eq Ord
|
|
||||||
SheetFile
|
|
||||||
sheet SheetId
|
|
||||||
file FileId
|
|
||||||
type SheetFileType
|
|
||||||
UniqueSheetFile file sheet type
|
|
||||||
File
|
|
||||||
title FilePath
|
|
||||||
content ByteString Maybe -- Nothing iff this is a directory
|
|
||||||
modified UTCTime
|
|
||||||
deriving Show Eq Generic
|
|
||||||
Submission
|
|
||||||
sheet SheetId
|
|
||||||
ratingPoints Points Maybe -- "Just" does not mean done
|
|
||||||
ratingComment Text Maybe -- "Just" does not mean done
|
|
||||||
ratingBy UserId Maybe -- assigned corrector
|
|
||||||
ratingAssigned UTCTime Maybe -- time assigned corrector
|
|
||||||
ratingTime UTCTime Maybe -- "Just" here indicates done!
|
|
||||||
deriving Show
|
|
||||||
SubmissionEdit
|
|
||||||
user UserId
|
|
||||||
time UTCTime
|
|
||||||
submission SubmissionId
|
|
||||||
SubmissionFile
|
|
||||||
submission SubmissionId
|
|
||||||
file FileId
|
|
||||||
isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
|
|
||||||
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
|
|
||||||
UniqueSubmissionFile file submission isUpdate
|
|
||||||
deriving Show
|
|
||||||
SubmissionUser -- Actual submission participant
|
|
||||||
user UserId
|
|
||||||
submission SubmissionId
|
|
||||||
UniqueSubmissionUser user submission
|
|
||||||
SubmissionGroup
|
|
||||||
course CourseId
|
|
||||||
name Text Maybe
|
|
||||||
SubmissionGroupEdit
|
|
||||||
user UserId
|
|
||||||
time UTCTime
|
|
||||||
submissionGroup SubmissionGroupId
|
|
||||||
SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser
|
|
||||||
submissionGroup SubmissionGroupId
|
|
||||||
user UserId
|
|
||||||
UniqueSubmissionGroupUser submissionGroup user
|
|
||||||
Tutorial json
|
|
||||||
name Text
|
|
||||||
tutor UserId
|
|
||||||
course CourseId
|
|
||||||
TutorialUser
|
|
||||||
user UserId
|
|
||||||
tutorial TutorialId
|
|
||||||
UniqueTutorialUser user tutorial
|
|
||||||
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
|
|
||||||
-- BookingRoom
|
|
||||||
-- subject RoomForId
|
|
||||||
-- room RoomId
|
|
||||||
-- booking BookingId
|
|
||||||
-- UniqueRoomCourse subject room booking
|
|
||||||
+RoomFor
|
|
||||||
course CourseId
|
|
||||||
tutorial TutorialId
|
|
||||||
exam ExamId
|
|
||||||
-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
|
|
||||||
-- EXAMS ARE TODO:
|
|
||||||
Exam
|
|
||||||
course CourseId
|
|
||||||
name Text
|
|
||||||
description Text
|
|
||||||
begin UTCTime
|
|
||||||
end UTCTime
|
|
||||||
registrationBegin UTCTime
|
|
||||||
registrationEnd UTCTime
|
|
||||||
deregistrationEnd UTCTime
|
|
||||||
ratingVisible Bool
|
|
||||||
statisticsVisible Bool
|
|
||||||
--ExamEdit
|
|
||||||
-- user UserId
|
|
||||||
-- time UTCTime
|
|
||||||
-- exam ExamId
|
|
||||||
--ExamUser
|
|
||||||
-- user UserId
|
|
||||||
-- examId ExamId
|
|
||||||
-- -- CONTINUE HERE: Include rating in this table or separately?
|
|
||||||
-- UniqueExamUser user examId
|
|
||||||
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
|
|
||||||
QueuedJob
|
|
||||||
content Value
|
|
||||||
creationInstance InstanceId
|
|
||||||
creationTime UTCTime
|
|
||||||
lockInstance InstanceId Maybe
|
|
||||||
lockTime UTCTime Maybe
|
|
||||||
deriving Eq Read Show Generic Typeable
|
|
||||||
CronLastExec
|
|
||||||
job Value
|
|
||||||
time UTCTime
|
|
||||||
instance InstanceId
|
|
||||||
UniqueCronLastExec job
|
|
||||||
SystemMessage
|
|
||||||
from UTCTime Maybe
|
|
||||||
to UTCTime Maybe
|
|
||||||
authenticatedOnly Bool
|
|
||||||
severity MessageClass
|
|
||||||
defaultLanguage Lang
|
|
||||||
content Html
|
|
||||||
summary Html Maybe
|
|
||||||
SystemMessageTranslation
|
|
||||||
message SystemMessageId
|
|
||||||
language Lang
|
|
||||||
content Html
|
|
||||||
summary Html Maybe
|
|
||||||
UniqueSystemMessageTranslation message language
|
|
||||||
ClusterConfig
|
|
||||||
setting ClusterSettingsKey
|
|
||||||
value Value
|
|
||||||
Primary setting
|
|
||||||
4
models/config
Normal file
4
models/config
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
ClusterConfig
|
||||||
|
setting ClusterSettingsKey
|
||||||
|
value Value
|
||||||
|
Primary setting
|
||||||
40
models/courses
Normal file
40
models/courses
Normal file
@ -0,0 +1,40 @@
|
|||||||
|
DegreeCourse json
|
||||||
|
course CourseId
|
||||||
|
degree StudyDegreeId
|
||||||
|
terms StudyTermsId
|
||||||
|
UniqueDegreeCourse course degree terms
|
||||||
|
Course
|
||||||
|
name (CI Text)
|
||||||
|
description Html Maybe
|
||||||
|
linkExternal Text Maybe
|
||||||
|
shorthand (CI Text)
|
||||||
|
term TermId
|
||||||
|
school SchoolId
|
||||||
|
capacity Int64 Maybe
|
||||||
|
-- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
|
||||||
|
registerFrom UTCTime Maybe
|
||||||
|
registerTo UTCTime Maybe
|
||||||
|
deregisterUntil UTCTime Maybe
|
||||||
|
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
||||||
|
materialFree Bool
|
||||||
|
TermSchoolCourseShort term school shorthand
|
||||||
|
TermSchoolCourseName term school name
|
||||||
|
CourseEdit
|
||||||
|
user UserId
|
||||||
|
time UTCTime
|
||||||
|
course CourseId
|
||||||
|
CourseFavourite
|
||||||
|
user UserId
|
||||||
|
time UTCTime
|
||||||
|
course CourseId
|
||||||
|
UniqueCourseFavourite user course
|
||||||
|
deriving Show
|
||||||
|
Lecturer
|
||||||
|
user UserId
|
||||||
|
course CourseId
|
||||||
|
UniqueLecturer user course
|
||||||
|
CourseParticipant
|
||||||
|
course CourseId
|
||||||
|
user UserId
|
||||||
|
registration UTCTime
|
||||||
|
UniqueParticipant user course
|
||||||
22
models/exams
Normal file
22
models/exams
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
-- EXAMS ARE TODO:
|
||||||
|
Exam
|
||||||
|
course CourseId
|
||||||
|
name Text
|
||||||
|
description Text
|
||||||
|
begin UTCTime
|
||||||
|
end UTCTime
|
||||||
|
registrationBegin UTCTime
|
||||||
|
registrationEnd UTCTime
|
||||||
|
deregistrationEnd UTCTime
|
||||||
|
ratingVisible Bool
|
||||||
|
statisticsVisible Bool
|
||||||
|
--ExamEdit
|
||||||
|
-- user UserId
|
||||||
|
-- time UTCTime
|
||||||
|
-- exam ExamId
|
||||||
|
--ExamUser
|
||||||
|
-- user UserId
|
||||||
|
-- examId ExamId
|
||||||
|
-- -- CONTINUE HERE: Include rating in this table or separately?
|
||||||
|
-- UniqueExamUser user examId
|
||||||
|
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
|
||||||
5
models/files
Normal file
5
models/files
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
File
|
||||||
|
title FilePath
|
||||||
|
content ByteString Maybe -- Nothing iff this is a directory
|
||||||
|
modified UTCTime
|
||||||
|
deriving Show Eq Generic
|
||||||
12
models/jobs
Normal file
12
models/jobs
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
QueuedJob
|
||||||
|
content Value
|
||||||
|
creationInstance InstanceId
|
||||||
|
creationTime UTCTime
|
||||||
|
lockInstance InstanceId Maybe
|
||||||
|
lockTime UTCTime Maybe
|
||||||
|
deriving Eq Read Show Generic Typeable
|
||||||
|
CronLastExec
|
||||||
|
job Value
|
||||||
|
time UTCTime
|
||||||
|
instance InstanceId
|
||||||
|
UniqueCronLastExec job
|
||||||
26
models/rooms
Normal file
26
models/rooms
Normal file
@ -0,0 +1,26 @@
|
|||||||
|
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
|
||||||
|
-- BookingRoom
|
||||||
|
-- subject RoomForId
|
||||||
|
-- room RoomId
|
||||||
|
-- booking BookingId
|
||||||
|
-- UniqueRoomCourse subject room booking
|
||||||
|
+RoomFor
|
||||||
|
course CourseId
|
||||||
|
tutorial TutorialId
|
||||||
|
exam ExamId
|
||||||
|
-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
|
||||||
7
models/schools
Normal file
7
models/schools
Normal file
@ -0,0 +1,7 @@
|
|||||||
|
School json
|
||||||
|
name (CI Text)
|
||||||
|
shorthand (CI Text)
|
||||||
|
UniqueSchool name
|
||||||
|
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
|
||||||
|
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
|
||||||
|
deriving Eq
|
||||||
38
models/sheets
Normal file
38
models/sheets
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
Sheet
|
||||||
|
course CourseId
|
||||||
|
name (CI Text)
|
||||||
|
description Html Maybe
|
||||||
|
type SheetType
|
||||||
|
grouping SheetGroup
|
||||||
|
markingText Html Maybe
|
||||||
|
visibleFrom UTCTime Maybe
|
||||||
|
activeFrom UTCTime
|
||||||
|
activeTo UTCTime
|
||||||
|
hintFrom UTCTime Maybe
|
||||||
|
solutionFrom UTCTime Maybe
|
||||||
|
uploadMode UploadMode
|
||||||
|
submissionMode SheetSubmissionMode default='UserSubmissions'
|
||||||
|
autoDistribute Bool default=false
|
||||||
|
CourseSheet course name
|
||||||
|
SheetEdit
|
||||||
|
user UserId
|
||||||
|
time UTCTime
|
||||||
|
sheet SheetId
|
||||||
|
SheetPseudonym
|
||||||
|
sheet SheetId
|
||||||
|
pseudonym Pseudonym
|
||||||
|
user UserId
|
||||||
|
UniqueSheetPseudonym sheet pseudonym
|
||||||
|
UniqueSheetPseudonymUser sheet user
|
||||||
|
SheetCorrector
|
||||||
|
user UserId
|
||||||
|
sheet SheetId
|
||||||
|
load Load
|
||||||
|
state CorrectorState default='CorrectorNormal'
|
||||||
|
UniqueSheetCorrector user sheet
|
||||||
|
deriving Show Eq Ord
|
||||||
|
SheetFile
|
||||||
|
sheet SheetId
|
||||||
|
file FileId
|
||||||
|
type SheetFileType
|
||||||
|
UniqueSheetFile file sheet type
|
||||||
34
models/submissions
Normal file
34
models/submissions
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
Submission
|
||||||
|
sheet SheetId
|
||||||
|
ratingPoints Points Maybe -- "Just" does not mean done
|
||||||
|
ratingComment Text Maybe -- "Just" does not mean done
|
||||||
|
ratingBy UserId Maybe -- assigned corrector
|
||||||
|
ratingAssigned UTCTime Maybe -- time assigned corrector
|
||||||
|
ratingTime UTCTime Maybe -- "Just" here indicates done!
|
||||||
|
deriving Show
|
||||||
|
SubmissionEdit
|
||||||
|
user UserId
|
||||||
|
time UTCTime
|
||||||
|
submission SubmissionId
|
||||||
|
SubmissionFile
|
||||||
|
submission SubmissionId
|
||||||
|
file FileId
|
||||||
|
isUpdate Bool -- is this the file updated by a corrector (original will always be retained)
|
||||||
|
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
|
||||||
|
UniqueSubmissionFile file submission isUpdate
|
||||||
|
deriving Show
|
||||||
|
SubmissionUser -- Actual submission participant
|
||||||
|
user UserId
|
||||||
|
submission SubmissionId
|
||||||
|
UniqueSubmissionUser user submission
|
||||||
|
SubmissionGroup
|
||||||
|
course CourseId
|
||||||
|
name Text Maybe
|
||||||
|
SubmissionGroupEdit
|
||||||
|
user UserId
|
||||||
|
time UTCTime
|
||||||
|
submissionGroup SubmissionGroupId
|
||||||
|
SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser
|
||||||
|
submissionGroup SubmissionGroupId
|
||||||
|
user UserId
|
||||||
|
UniqueSubmissionGroupUser submissionGroup user
|
||||||
14
models/system-messages
Normal file
14
models/system-messages
Normal file
@ -0,0 +1,14 @@
|
|||||||
|
SystemMessage
|
||||||
|
from UTCTime Maybe
|
||||||
|
to UTCTime Maybe
|
||||||
|
authenticatedOnly Bool
|
||||||
|
severity MessageClass
|
||||||
|
defaultLanguage Lang
|
||||||
|
content Html
|
||||||
|
summary Html Maybe
|
||||||
|
SystemMessageTranslation
|
||||||
|
message SystemMessageId
|
||||||
|
language Lang
|
||||||
|
content Html
|
||||||
|
summary Html Maybe
|
||||||
|
UniqueSystemMessageTranslation message language
|
||||||
10
models/terms
Normal file
10
models/terms
Normal file
@ -0,0 +1,10 @@
|
|||||||
|
Term json
|
||||||
|
name TermIdentifier -- unTermKey :: TermId -> TermIdentifier
|
||||||
|
start Day -- TermKey :: TermIdentifier -> TermId
|
||||||
|
end Day
|
||||||
|
holidays [Day]
|
||||||
|
lectureStart Day
|
||||||
|
lectureEnd Day
|
||||||
|
active Bool
|
||||||
|
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
|
||||||
|
deriving Show -- type TermId = Key Term
|
||||||
8
models/tutorials
Normal file
8
models/tutorials
Normal file
@ -0,0 +1,8 @@
|
|||||||
|
Tutorial json
|
||||||
|
name Text
|
||||||
|
tutor UserId
|
||||||
|
course CourseId
|
||||||
|
TutorialUser
|
||||||
|
user UserId
|
||||||
|
tutorial TutorialId
|
||||||
|
UniqueTutorialUser user tutorial
|
||||||
43
models/users
Normal file
43
models/users
Normal file
@ -0,0 +1,43 @@
|
|||||||
|
User json
|
||||||
|
ident (CI Text)
|
||||||
|
authentication AuthenticationMode
|
||||||
|
matrikelnummer Text Maybe
|
||||||
|
email (CI Text)
|
||||||
|
displayName Text
|
||||||
|
surname Text -- always use: nameWidget displayName surname
|
||||||
|
maxFavourites Int default=12
|
||||||
|
theme Theme default='Default'
|
||||||
|
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
|
||||||
|
dateFormat DateTimeFormat "default='%d.%m.%Y'"
|
||||||
|
timeFormat DateTimeFormat "default='%R'"
|
||||||
|
downloadFiles Bool default=false
|
||||||
|
mailLanguages MailLanguages default='[]'
|
||||||
|
notificationSettings NotificationSettings
|
||||||
|
UniqueAuthentication ident
|
||||||
|
UniqueEmail email
|
||||||
|
deriving Show Eq
|
||||||
|
UserAdmin
|
||||||
|
user UserId
|
||||||
|
school SchoolId
|
||||||
|
UniqueUserAdmin user school
|
||||||
|
UserLecturer
|
||||||
|
user UserId
|
||||||
|
school SchoolId
|
||||||
|
UniqueSchoolLecturer user school
|
||||||
|
StudyFeatures
|
||||||
|
user UserId
|
||||||
|
degree StudyDegreeId
|
||||||
|
field StudyTermsId
|
||||||
|
type StudyFieldType
|
||||||
|
semester Int
|
||||||
|
-- UniqueUserSubject user degree field -- There exists a counterexample
|
||||||
|
StudyDegree
|
||||||
|
key Int
|
||||||
|
shorthand Text Maybe
|
||||||
|
name Text Maybe
|
||||||
|
Primary key
|
||||||
|
StudyTerms
|
||||||
|
key Int
|
||||||
|
shorthand Text Maybe
|
||||||
|
name Text Maybe
|
||||||
|
Primary key
|
||||||
@ -112,6 +112,7 @@ dependencies:
|
|||||||
- text-metrics
|
- text-metrics
|
||||||
- pkcs7
|
- pkcs7
|
||||||
- memcached-binary
|
- memcached-binary
|
||||||
|
- directory-tree
|
||||||
|
|
||||||
other-extensions:
|
other-extensions:
|
||||||
- GeneralizedNewtypeDeriving
|
- GeneralizedNewtypeDeriving
|
||||||
@ -162,6 +163,7 @@ default-extensions:
|
|||||||
- PolyKinds
|
- PolyKinds
|
||||||
- PackageImports
|
- PackageImports
|
||||||
- TypeApplications
|
- TypeApplications
|
||||||
|
- RecursiveDo
|
||||||
|
|
||||||
ghc-options:
|
ghc-options:
|
||||||
- -Wall
|
- -Wall
|
||||||
|
|||||||
6
routes
6
routes
@ -36,7 +36,7 @@
|
|||||||
/users UsersR GET -- no tags, i.e. admins only
|
/users UsersR GET -- no tags, i.e. admins only
|
||||||
/admin/test AdminTestR GET POST
|
/admin/test AdminTestR GET POST
|
||||||
/admin/user/#CryptoUUIDUser AdminUserR GET !development
|
/admin/user/#CryptoUUIDUser AdminUserR GET !development
|
||||||
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
|
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
|
||||||
/admin/errMsg AdminErrMsgR GET POST
|
/admin/errMsg AdminErrMsgR GET POST
|
||||||
/info VersionR GET !free
|
/info VersionR GET !free
|
||||||
/help HelpR GET POST !free
|
/help HelpR GET POST !free
|
||||||
@ -60,7 +60,6 @@
|
|||||||
-- For Pattern Synonyms see Foundation
|
-- For Pattern Synonyms see Foundation
|
||||||
/course/ CourseListR GET !free
|
/course/ CourseListR GET !free
|
||||||
!/course/new CourseNewR GET POST !lecturer
|
!/course/new CourseNewR GET POST !lecturer
|
||||||
!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer
|
|
||||||
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
|
||||||
/ CShowR GET !free
|
/ CShowR GET !free
|
||||||
/register CRegisterR POST !timeANDcapacity
|
/register CRegisterR POST !timeANDcapacity
|
||||||
@ -80,8 +79,9 @@
|
|||||||
!/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
|
!/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
|
||||||
!/subs/own SubmissionOwnR GET !free -- just redirect
|
!/subs/own SubmissionOwnR GET !free -- just redirect
|
||||||
/subs/#CryptoFileNameSubmission SubmissionR:
|
/subs/#CryptoFileNameSubmission SubmissionR:
|
||||||
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
||||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
|
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
|
||||||
|
/delete SubDelR GET POST !ownerANDtime
|
||||||
/assign SAssignR GET POST !lecturerANDtime
|
/assign SAssignR GET POST !lecturerANDtime
|
||||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||||
|
|||||||
@ -139,13 +139,14 @@ makeFoundation appSettings@AppSettings{..} = do
|
|||||||
-- logging function. To get out of this loop, we initially create a
|
-- logging function. To get out of this loop, we initially create a
|
||||||
-- temporary foundation without a real connection pool, get a log function
|
-- temporary foundation without a real connection pool, get a log function
|
||||||
-- from there, and then create the real foundation.
|
-- from there, and then create the real foundation.
|
||||||
let mkFoundation appConnPool appSmtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
|
let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..}
|
||||||
-- The UniWorX {..} syntax is an example of record wild cards. For more
|
-- The UniWorX {..} syntax is an example of record wild cards. For more
|
||||||
-- information, see:
|
-- information, see:
|
||||||
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
|
||||||
tempFoundation = mkFoundation
|
tempFoundation = mkFoundation
|
||||||
(error "connPool forced in tempFoundation")
|
(error "connPool forced in tempFoundation")
|
||||||
(error "smtpPool forced in tempFoundation")
|
(error "smtpPool forced in tempFoundation")
|
||||||
|
(error "ldapPool forced in tempFoundation")
|
||||||
(error "cryptoIDKey forced in tempFoundation")
|
(error "cryptoIDKey forced in tempFoundation")
|
||||||
(error "sessionKey forced in tempFoundation")
|
(error "sessionKey forced in tempFoundation")
|
||||||
(error "secretBoxKey forced in tempFoundation")
|
(error "secretBoxKey forced in tempFoundation")
|
||||||
@ -167,13 +168,15 @@ makeFoundation appSettings@AppSettings{..} = do
|
|||||||
(pgConnStr appDatabaseConf)
|
(pgConnStr appDatabaseConf)
|
||||||
(pgPoolSize appDatabaseConf)
|
(pgPoolSize appDatabaseConf)
|
||||||
|
|
||||||
|
ldapPool <- for appLdapConf $ \LdapConf{..} -> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) (poolLimit ldapPool)
|
||||||
|
|
||||||
-- Perform database migration using our application's logging settings.
|
-- Perform database migration using our application's logging settings.
|
||||||
migrateAll `runSqlPool` sqlPool
|
migrateAll `runSqlPool` sqlPool
|
||||||
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool
|
||||||
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool
|
||||||
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
|
appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
|
||||||
|
|
||||||
let foundation = mkFoundation sqlPool smtpPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
|
let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached
|
||||||
|
|
||||||
handleJobs foundation
|
handleJobs foundation
|
||||||
|
|
||||||
|
|||||||
@ -13,10 +13,12 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
|
|
||||||
|
|
||||||
data DummyMessage = MsgDummyIdent
|
data DummyMessage = MsgDummyIdent
|
||||||
|
| MsgDummyNoFormData
|
||||||
|
|
||||||
|
|
||||||
dummyForm :: ( RenderMessage site FormMessage
|
dummyForm :: ( RenderMessage site FormMessage
|
||||||
, RenderMessage site DummyMessage
|
, RenderMessage site DummyMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, YesodPersist site
|
, YesodPersist site
|
||||||
, SqlBackendCanRead (YesodPersistBackend site)
|
, SqlBackendCanRead (YesodPersistBackend site)
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
@ -33,6 +35,7 @@ dummyLogin :: ( YesodAuth site
|
|||||||
, SqlBackendCanRead (YesodPersistBackend site)
|
, SqlBackendCanRead (YesodPersistBackend site)
|
||||||
, RenderMessage site FormMessage
|
, RenderMessage site FormMessage
|
||||||
, RenderMessage site DummyMessage
|
, RenderMessage site DummyMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
, Show (ButtonCssClass site)
|
, Show (ButtonCssClass site)
|
||||||
) => AuthPlugin site
|
) => AuthPlugin site
|
||||||
@ -46,7 +49,9 @@ dummyLogin = AuthPlugin{..}
|
|||||||
FormFailure errs -> do
|
FormFailure errs -> do
|
||||||
lift . forM_ errs $ addMessage Error . toHtml
|
lift . forM_ errs $ addMessage Error . toHtml
|
||||||
redirect LoginR
|
redirect LoginR
|
||||||
FormMissing -> redirect LoginR
|
FormMissing -> do
|
||||||
|
lift $ addMessageI Warning MsgDummyNoFormData
|
||||||
|
redirect LoginR
|
||||||
FormSuccess ident ->
|
FormSuccess ident ->
|
||||||
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
|
||||||
apDispatch _ _ = notFound
|
apDispatch _ _ = notFound
|
||||||
|
|||||||
@ -17,6 +17,7 @@ import qualified Control.Monad.Catch as Exc
|
|||||||
|
|
||||||
import Utils.Form
|
import Utils.Form
|
||||||
|
|
||||||
|
import Ldap.Client (Ldap)
|
||||||
import qualified Ldap.Client as Ldap
|
import qualified Ldap.Client as Ldap
|
||||||
|
|
||||||
import qualified Data.Text.Encoding as Text
|
import qualified Data.Text.Encoding as Text
|
||||||
@ -36,7 +37,7 @@ data CampusMessage = MsgCampusIdentNote
|
|||||||
| MsgCampusInvalidCredentials
|
| MsgCampusInvalidCredentials
|
||||||
|
|
||||||
|
|
||||||
findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
|
||||||
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
|
||||||
where
|
where
|
||||||
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
|
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
|
||||||
@ -52,6 +53,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
|
|||||||
|
|
||||||
campusForm :: ( RenderMessage site FormMessage
|
campusForm :: ( RenderMessage site FormMessage
|
||||||
, RenderMessage site CampusMessage
|
, RenderMessage site CampusMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
, Show (ButtonCssClass site)
|
, Show (ButtonCssClass site)
|
||||||
) => AForm (HandlerT site IO) CampusLogin
|
) => AForm (HandlerT site IO) CampusLogin
|
||||||
@ -64,10 +66,11 @@ campusLogin :: forall site.
|
|||||||
( YesodAuth site
|
( YesodAuth site
|
||||||
, RenderMessage site FormMessage
|
, RenderMessage site FormMessage
|
||||||
, RenderMessage site CampusMessage
|
, RenderMessage site CampusMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
, Show (ButtonCssClass site)
|
, Show (ButtonCssClass site)
|
||||||
) => LdapConf -> AuthPlugin site
|
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||||
campusLogin conf@LdapConf{..} = AuthPlugin{..}
|
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||||
where
|
where
|
||||||
apName = "LDAP"
|
apName = "LDAP"
|
||||||
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
|
||||||
@ -79,7 +82,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
|
|||||||
redirect LoginR
|
redirect LoginR
|
||||||
FormMissing -> redirect LoginR
|
FormMissing -> redirect LoginR
|
||||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||||
ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
|
ldapResult <- withLdap pool $ \ldap -> do
|
||||||
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
|
||||||
Ldap.bind ldap ldapDn ldapPassword
|
Ldap.bind ldap ldapDn ldapPassword
|
||||||
findUser conf ldap campusIdent [userPrincipalName]
|
findUser conf ldap campusIdent [userPrincipalName]
|
||||||
@ -117,8 +120,8 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
|
|||||||
|
|
||||||
instance Exception CampusUserException
|
instance Exception CampusUserException
|
||||||
|
|
||||||
campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
|
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||||
campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
|
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||||
Ldap.bind ldap ldapDn ldapPassword
|
Ldap.bind ldap ldapDn ldapPassword
|
||||||
results <- case lookup "DN" credsExtra of
|
results <- case lookup "DN" credsExtra of
|
||||||
Just userDN -> do
|
Just userDN -> do
|
||||||
|
|||||||
@ -27,6 +27,7 @@ data PWHashMessage = MsgPWHashIdent
|
|||||||
|
|
||||||
hashForm :: ( RenderMessage site FormMessage
|
hashForm :: ( RenderMessage site FormMessage
|
||||||
, RenderMessage site PWHashMessage
|
, RenderMessage site PWHashMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
, Show (ButtonCssClass site)
|
, Show (ButtonCssClass site)
|
||||||
) => AForm (HandlerT site IO) HashLogin
|
) => AForm (HandlerT site IO) HashLogin
|
||||||
@ -41,6 +42,7 @@ hashLogin :: ( YesodAuth site
|
|||||||
, SqlBackendCanRead (YesodPersistBackend site)
|
, SqlBackendCanRead (YesodPersistBackend site)
|
||||||
, RenderMessage site FormMessage
|
, RenderMessage site FormMessage
|
||||||
, RenderMessage site PWHashMessage
|
, RenderMessage site PWHashMessage
|
||||||
|
, RenderMessage site ButtonMessage
|
||||||
, Button site SubmitButton
|
, Button site SubmitButton
|
||||||
, Show (ButtonCssClass site)
|
, Show (ButtonCssClass site)
|
||||||
) => PWHashAlgorithm -> AuthPlugin site
|
) => PWHashAlgorithm -> AuthPlugin site
|
||||||
|
|||||||
@ -25,6 +25,9 @@ import Web.PathPieces
|
|||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(..), FromJSONKey(..), FromJSONKeyFunction(..), Value(..), withText)
|
||||||
|
import Data.Aeson.Encoding (text)
|
||||||
|
|
||||||
|
|
||||||
-- Generates CryptoUUID... and CryptoFileName... Datatypes
|
-- Generates CryptoUUID... and CryptoFileName... Datatypes
|
||||||
decCryptoIDs [ ''SubmissionId
|
decCryptoIDs [ ''SubmissionId
|
||||||
@ -41,6 +44,15 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
|
|||||||
return . CryptoID . CI.mk $ map CI.original piece'
|
return . CryptoID . CI.mk $ map CI.original piece'
|
||||||
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
|
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
|
||||||
|
|
||||||
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSON (E.CryptoID namespace (CI FilePath)) where
|
||||||
|
toJSON = String . toPathPiece
|
||||||
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => ToJSONKey (E.CryptoID namespace (CI FilePath)) where
|
||||||
|
toJSONKey = ToJSONKeyText toPathPiece (text . toPathPiece)
|
||||||
|
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSON (E.CryptoID namespace (CI FilePath)) where
|
||||||
|
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)
|
newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
|
||||||
deriving (Show, Read, Eq)
|
deriving (Show, Read, Eq)
|
||||||
|
|||||||
@ -1,3 +1,4 @@
|
|||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
module Data.CaseInsensitive.Instances
|
module Data.CaseInsensitive.Instances
|
||||||
@ -12,6 +13,7 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
import Database.Persist.Sql
|
import Database.Persist.Sql
|
||||||
|
|
||||||
import Text.Blaze (ToMarkup(..))
|
import Text.Blaze (ToMarkup(..))
|
||||||
|
import Text.Shakespeare.Text (ToText(..))
|
||||||
|
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text.Encoding as Text
|
import qualified Data.Text.Encoding as Text
|
||||||
@ -20,6 +22,8 @@ import Language.Haskell.TH.Syntax (Lift(..))
|
|||||||
|
|
||||||
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
|
import Data.Aeson (ToJSON(..), FromJSON(..), ToJSONKey(..), FromJSONKey(..), ToJSONKeyFunction(..))
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
instance PersistField (CI Text) where
|
instance PersistField (CI Text) where
|
||||||
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
|
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
|
||||||
@ -37,6 +41,8 @@ instance PersistFieldSql (CI Text) where
|
|||||||
instance PersistFieldSql (CI String) where
|
instance PersistFieldSql (CI String) where
|
||||||
sqlType _ = SqlOther "citext"
|
sqlType _ = SqlOther "citext"
|
||||||
|
|
||||||
|
instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
|
||||||
|
|
||||||
instance ToJSON a => ToJSON (CI a) where
|
instance ToJSON a => ToJSON (CI a) where
|
||||||
toJSON = toJSON . CI.original
|
toJSON = toJSON . CI.original
|
||||||
|
|
||||||
@ -58,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where
|
|||||||
toMarkup = toMarkup . CI.original
|
toMarkup = toMarkup . CI.original
|
||||||
preEscapedToMarkup = preEscapedToMarkup . CI.original
|
preEscapedToMarkup = preEscapedToMarkup . CI.original
|
||||||
|
|
||||||
|
instance ToText a => ToText (CI a) where
|
||||||
|
toText = toText . CI.original
|
||||||
|
|
||||||
instance ToWidget site a => ToWidget site (CI a) where
|
instance ToWidget site a => ToWidget site (CI a) where
|
||||||
toWidget = toWidget . CI.original
|
toWidget = toWidget . CI.original
|
||||||
|
|
||||||
|
|||||||
19
src/Data/Monoid/Instances.hs
Normal file
19
src/Data/Monoid/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
|
module Data.Monoid.Instances
|
||||||
|
(
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Data.Monoid
|
||||||
|
|
||||||
|
type instance Element (Dual a) = a
|
||||||
|
instance MonoPointed (Dual a)
|
||||||
|
type instance Element (Sum a) = a
|
||||||
|
instance MonoPointed (Sum a)
|
||||||
|
type instance Element (Product a) = a
|
||||||
|
instance MonoPointed (Product a)
|
||||||
|
type instance Element (First a) = a
|
||||||
|
instance MonoPointed (First a)
|
||||||
|
type instance Element (Last a) = a
|
||||||
|
instance MonoPointed (Last a)
|
||||||
27
src/Database/Persist/TH/Directory.hs
Normal file
27
src/Database/Persist/TH/Directory.hs
Normal file
@ -0,0 +1,27 @@
|
|||||||
|
module Database.Persist.TH.Directory
|
||||||
|
( persistDirectoryWith
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ClassyPrelude hiding (mapM_, toList)
|
||||||
|
|
||||||
|
import Database.Persist.TH (parseReferences)
|
||||||
|
import Database.Persist.Quasi (PersistSettings)
|
||||||
|
import Language.Haskell.TH.Syntax
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Data.Text.IO as Text
|
||||||
|
import qualified System.IO as SIO
|
||||||
|
|
||||||
|
import qualified System.Directory.Tree as DirTree
|
||||||
|
|
||||||
|
import Data.Foldable (Foldable(..), mapM_)
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files
|
||||||
@ -102,6 +102,7 @@ data UniWorX = UniWorX
|
|||||||
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
||||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||||
, appSmtpPool :: Maybe SMTPPool
|
, appSmtpPool :: Maybe SMTPPool
|
||||||
|
, appLdapPool :: Maybe LdapPool
|
||||||
, appWidgetMemcached :: Maybe Memcached.Connection
|
, appWidgetMemcached :: Maybe Memcached.Connection
|
||||||
, appHttpManager :: Manager
|
, appHttpManager :: Manager
|
||||||
, appLogger :: (ReleaseKey, TVar Logger)
|
, appLogger :: (ReleaseKey, TVar Logger)
|
||||||
@ -145,11 +146,22 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
|
|||||||
pattern CSubmissionR tid ssh csh shn cid ptn
|
pattern CSubmissionR tid ssh csh shn cid ptn
|
||||||
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
= CSheetR tid ssh csh shn (SubmissionR cid ptn)
|
||||||
|
|
||||||
|
|
||||||
|
pluralDE :: (Eq a, Num a)
|
||||||
|
=> a -- ^ Count
|
||||||
|
-> Text -- ^ Singular
|
||||||
|
-> Text -- ^ Plural
|
||||||
|
-> Text
|
||||||
|
pluralDE num singularForm pluralForm
|
||||||
|
| num == 1 = singularForm
|
||||||
|
| otherwise = pluralForm
|
||||||
|
|
||||||
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
-- Messages creates type UniWorXMessage and RenderMessage UniWorX instance
|
||||||
mkMessage "UniWorX" "messages/uniworx" "de"
|
mkMessage "UniWorX" "messages/uniworx" "de"
|
||||||
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
|
||||||
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
|
||||||
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
|
mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
|
||||||
|
mkMessageVariant "UniWorX" "Button" "messages/button" "de"
|
||||||
|
|
||||||
-- This instance is required to use forms. You can modify renderMessage to
|
-- This instance is required to use forms. You can modify renderMessage to
|
||||||
-- achieve customized and internationalized form validation messages.
|
-- achieve customized and internationalized form validation messages.
|
||||||
@ -198,6 +210,7 @@ embedRenderMessage ''UniWorX ''StudyFieldType id
|
|||||||
embedRenderMessage ''UniWorX ''SheetFileType id
|
embedRenderMessage ''UniWorX ''SheetFileType id
|
||||||
embedRenderMessage ''UniWorX ''CorrectorState id
|
embedRenderMessage ''UniWorX ''CorrectorState id
|
||||||
embedRenderMessage ''UniWorX ''RatingException id
|
embedRenderMessage ''UniWorX ''RatingException id
|
||||||
|
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
|
||||||
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
|
||||||
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
|
||||||
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
|
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
|
||||||
@ -360,6 +373,16 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
|
|||||||
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
|
||||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||||
return Authorized
|
return Authorized
|
||||||
|
tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of
|
||||||
|
AdminHijackUserR cID -> exceptT return return $ do
|
||||||
|
myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||||
|
uid <- decrypt cID
|
||||||
|
otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
||||||
|
otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
||||||
|
mySchools <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
|
||||||
|
guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
|
||||||
|
return Authorized
|
||||||
|
r -> $unsupportedAuthPredicate AuthNoEscalation r
|
||||||
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
|
tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
|
||||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||||
addMessageI Error MsgDeprecatedRoute
|
addMessageI Error MsgDeprecatedRoute
|
||||||
@ -479,8 +502,11 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
|
|||||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
||||||
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||||
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||||
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
|
assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
|
||||||
guard $ registered <= 0
|
assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
||||||
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||||
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||||
|
return E.countRows
|
||||||
return Authorized
|
return Authorized
|
||||||
r -> $unsupportedAuthPredicate AuthEmpty r
|
r -> $unsupportedAuthPredicate AuthEmpty r
|
||||||
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
|
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
|
||||||
@ -1178,7 +1204,15 @@ pageActions (CourseR tid ssh csh CShowR) =
|
|||||||
{ menuItemType = PageActionSecondary
|
{ menuItemType = PageActionSecondary
|
||||||
, menuItemLabel = MsgMenuCourseNewTemplate
|
, menuItemLabel = MsgMenuCourseNewTemplate
|
||||||
, menuItemIcon = Nothing
|
, menuItemIcon = Nothing
|
||||||
, menuItemRoute = SomeRoute $ CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
|
, menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
|
, MenuItem
|
||||||
|
{ menuItemType = PageActionSecondary
|
||||||
|
, menuItemLabel = MsgMenuCourseDelete
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
|
||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
@ -1242,6 +1276,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
|
|||||||
, menuItemModal = False
|
, menuItemModal = False
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
|
, MenuItem
|
||||||
|
{ menuItemType = PageActionSecondary
|
||||||
|
, menuItemLabel = MsgMenuSheetDelete
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
]
|
]
|
||||||
pageActions (CSheetR tid ssh csh shn SSubsR) =
|
pageActions (CSheetR tid ssh csh shn SSubsR) =
|
||||||
[ MenuItem
|
[ MenuItem
|
||||||
@ -1270,6 +1312,24 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
|
|||||||
, menuItemModal = True
|
, menuItemModal = True
|
||||||
, menuItemAccessCallback' = return True
|
, menuItemAccessCallback' = return True
|
||||||
}
|
}
|
||||||
|
, MenuItem
|
||||||
|
{ menuItemType = PageActionSecondary
|
||||||
|
, menuItemLabel = MsgMenuSubmissionDelete
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
|
]
|
||||||
|
pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
|
||||||
|
[ MenuItem
|
||||||
|
{ menuItemType = PageActionSecondary
|
||||||
|
, menuItemLabel = MsgMenuSubmissionDelete
|
||||||
|
, menuItemIcon = Nothing
|
||||||
|
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
|
||||||
|
, menuItemModal = False
|
||||||
|
, menuItemAccessCallback' = return True
|
||||||
|
}
|
||||||
]
|
]
|
||||||
pageActions (CSheetR tid ssh csh shn SCorrR) =
|
pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||||
[ MenuItem
|
[ MenuItem
|
||||||
@ -1581,11 +1641,11 @@ instance YesodAuth UniWorX where
|
|||||||
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
|
||||||
|
|
||||||
$logDebugS "auth" $ tshow Creds{..}
|
$logDebugS "auth" $ tshow Creds{..}
|
||||||
AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings
|
UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||||
|
|
||||||
flip catches excHandlers $ case appLdapConf of
|
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||||
Just ldapConf -> fmap (either id id) . runExceptT $ do
|
Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
|
||||||
ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra
|
ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra
|
||||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||||
|
|
||||||
let
|
let
|
||||||
@ -1669,8 +1729,8 @@ instance YesodAuth UniWorX where
|
|||||||
where
|
where
|
||||||
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
|
||||||
|
|
||||||
authPlugins (appSettings -> AppSettings{..}) = catMaybes
|
authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
|
||||||
[ campusLogin <$> appLdapConf
|
[ campusLogin <$> appLdapConf <*> appLdapPool
|
||||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||||
, dummyLogin <$ guard appAuthDummyLogin
|
, dummyLogin <$ guard appAuthDummyLogin
|
||||||
]
|
]
|
||||||
|
|||||||
@ -8,6 +8,7 @@ import Handler.Utils
|
|||||||
import Handler.Utils.Submission
|
import Handler.Utils.Submission
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
import Handler.Utils.SheetType
|
import Handler.Utils.SheetType
|
||||||
|
import Handler.Utils.Delete
|
||||||
-- import Handler.Utils.Zip
|
-- import Handler.Utils.Zip
|
||||||
|
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
@ -39,8 +40,6 @@ import qualified Database.Esqueleto as E
|
|||||||
|
|
||||||
-- import Network.Mime
|
-- import Network.Mime
|
||||||
|
|
||||||
import Web.PathPieces
|
|
||||||
|
|
||||||
import Text.Hamlet (ihamletFile)
|
import Text.Hamlet (ihamletFile)
|
||||||
|
|
||||||
import Database.Persist.Sql (updateWhereCount)
|
import Database.Persist.Sql (updateWhereCount)
|
||||||
@ -127,8 +126,8 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
|||||||
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
return $ CSubmissionR tid ssh csh shn cid SubShowR
|
||||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||||
|
|
||||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||||
|
|
||||||
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
|
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
|
||||||
@ -174,12 +173,12 @@ colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_
|
|||||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||||
|
|
||||||
colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
|
colRatedField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
|
||||||
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell
|
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
|
||||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||||
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
|
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
|
||||||
|
|
||||||
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
|
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
|
||||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell
|
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
|
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
|
||||||
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||||||
@ -187,14 +186,14 @@ colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ for
|
|||||||
)
|
)
|
||||||
|
|
||||||
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
|
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
|
||||||
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
|
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
|
||||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
|
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
|
||||||
|
|
||||||
|
|
||||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||||
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
|
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
|
||||||
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do
|
||||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||||
dbtSQLQuery = correctionsTableQuery whereClause
|
dbtSQLQuery = correctionsTableQuery whereClause
|
||||||
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
|
(\((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) ->
|
||||||
@ -219,6 +218,7 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
|||||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||||
dbTable psValidator DBTable
|
dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
|
||||||
, dbtColonnade
|
, dbtColonnade
|
||||||
, dbtProj
|
, dbtProj
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
@ -248,10 +248,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
|||||||
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||||
E.orderBy [E.asc $ user E.^. UserDisplayName]
|
E.orderBy [E.asc $ user E.^. UserSurname]
|
||||||
E.limit 1
|
E.limit 1
|
||||||
return (user E.^. UserDisplayName)
|
return (user E.^. UserSurname)
|
||||||
|
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilter = Map.fromList
|
, dbtFilter = Map.fromList
|
||||||
@ -277,36 +276,59 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
|
|||||||
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
|
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams
|
||||||
, dbtIdent = "corrections" :: Text
|
, dbtIdent = "corrections" :: Text
|
||||||
}
|
}
|
||||||
|
|
||||||
data ActionCorrections = CorrDownload
|
data ActionCorrections = CorrDownload
|
||||||
| CorrSetCorrector
|
| CorrSetCorrector
|
||||||
| CorrAutoSetCorrector
|
| CorrAutoSetCorrector
|
||||||
|
| CorrDelete
|
||||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||||
instance PathPiece ActionCorrections where
|
|
||||||
fromPathPiece = readFromPathPiece
|
|
||||||
toPathPiece = showToPathPiece
|
|
||||||
|
|
||||||
instance RenderMessage UniWorX ActionCorrections where
|
instance Universe ActionCorrections
|
||||||
renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
|
instance Finite ActionCorrections
|
||||||
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
|
|
||||||
renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
|
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
|
||||||
|
embedRenderMessage ''UniWorX ''ActionCorrections id
|
||||||
|
|
||||||
data ActionCorrectionsData = CorrDownloadData
|
data ActionCorrectionsData = CorrDownloadData
|
||||||
| CorrSetCorrectorData (Maybe UserId)
|
| CorrSetCorrectorData (Maybe UserId)
|
||||||
| CorrAutoSetCorrectorData SheetId
|
| CorrAutoSetCorrectorData SheetId
|
||||||
|
| CorrDeleteData
|
||||||
|
|
||||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
|
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
|
||||||
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
||||||
tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator return
|
|
||||||
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
|
|
||||||
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
|
|
||||||
(actionRes, action) <- multiAction actions Nothing
|
|
||||||
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
|
||||||
|
|
||||||
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
|
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
|
||||||
|
|
||||||
|
postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords)
|
||||||
|
{ drAbort = SomeRoute currentRoute
|
||||||
|
, drSuccess = SomeRoute currentRoute
|
||||||
|
}
|
||||||
|
|
||||||
|
((actionRes', table), statistics) <- runDB $ do
|
||||||
|
-- Query for Table
|
||||||
|
tableRes <- makeCorrectionsTable whereClause displayColumns psValidator return def
|
||||||
|
{ dbParamsFormAction = Just $ SomeRoute currentRoute
|
||||||
|
, dbParamsFormAddSubmit = True
|
||||||
|
, dbParamsFormAdditional = \frag -> do
|
||||||
|
(actionRes, action) <- multiAction actions Nothing
|
||||||
|
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||||
|
}
|
||||||
|
-- Similar Query for Statistics over alle possible Table elements (not just the ones shown)
|
||||||
|
gradingSummary <- do
|
||||||
|
let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
|
||||||
|
points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
|
||||||
|
-- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
|
||||||
|
return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
|
||||||
|
let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
||||||
|
return (tableRes, statistics)
|
||||||
|
|
||||||
|
let actionRes = actionRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||||
|
& mapped._1 %~ fromMaybe (error "By consctruction the form should always return an action") . getLast
|
||||||
|
|
||||||
case actionRes of
|
case actionRes of
|
||||||
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
|
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
|
||||||
FormMissing -> return ()
|
FormMissing -> return ()
|
||||||
@ -377,13 +399,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
|||||||
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
|
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
|
||||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||||
redirect currentRoute
|
redirect currentRoute
|
||||||
|
FormSuccess (CorrDeleteData, subs) -> do
|
||||||
|
subs' <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||||||
|
getDeleteR (submissionDeleteRoute subs')
|
||||||
|
{ drAbort = SomeRoute currentRoute
|
||||||
|
, drSuccess = SomeRoute currentRoute
|
||||||
|
}
|
||||||
|
|
||||||
gradingSummary <- runDB $ do
|
|
||||||
let getTypePoints ((_course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = (sheet E.^. SheetType, submission E.^. SubmissionRatingPoints, submission E.^. SubmissionRatingTime)
|
|
||||||
points <- E.select . E.from $ correctionsTableQuery whereClause getTypePoints
|
|
||||||
-- points <- E.select . E.from $ t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> (correctionsTableQuery whereClause getTypePoints t) <* E.distinctOn []
|
|
||||||
return $ foldMap (\(E.Value stype, E.Value srpoints, E.Value srtime) -> sheetTypeSum stype (srpoints <* srtime)) points
|
|
||||||
let statistics = gradeSummaryWidget MsgSubmissionGradingSummaryTitle gradingSummary
|
|
||||||
fmap toTypedContent . defaultLayout $ do
|
fmap toTypedContent . defaultLayout $ do
|
||||||
setTitleI MsgCourseCorrectionsTitle
|
setTitleI MsgCourseCorrectionsTitle
|
||||||
$(widgetFile "corrections")
|
$(widgetFile "corrections")
|
||||||
@ -403,10 +425,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
|||||||
|
|
||||||
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
|
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
|
||||||
|
|
||||||
downloadAction :: ActionCorrections'
|
downloadAction, deleteAction :: ActionCorrections'
|
||||||
downloadAction = ( CorrDownload
|
downloadAction = ( CorrDownload
|
||||||
, pure CorrDownloadData
|
, pure CorrDownloadData
|
||||||
)
|
)
|
||||||
|
deleteAction = ( CorrDelete
|
||||||
|
, pure CorrDeleteData
|
||||||
|
)
|
||||||
|
|
||||||
assignAction :: Either CourseId SheetId -> ActionCorrections'
|
assignAction :: Either CourseId SheetId -> ActionCorrections'
|
||||||
assignAction selId = ( CorrSetCorrector
|
assignAction selId = ( CorrSetCorrector
|
||||||
@ -478,6 +503,7 @@ postCCorrectionsR tid ssh csh = do
|
|||||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||||
[ downloadAction
|
[ downloadAction
|
||||||
, assignAction (Left cid)
|
, assignAction (Left cid)
|
||||||
|
, deleteAction
|
||||||
]
|
]
|
||||||
|
|
||||||
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||||
@ -501,6 +527,7 @@ postSSubsR tid ssh csh shn = do
|
|||||||
[ downloadAction
|
[ downloadAction
|
||||||
, assignAction (Right shid)
|
, assignAction (Right shid)
|
||||||
, autoAssignAction shid
|
, autoAssignAction shid
|
||||||
|
, deleteAction
|
||||||
]
|
]
|
||||||
|
|
||||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||||
@ -579,13 +606,12 @@ postCorrectionR tid ssh csh shn cid = do
|
|||||||
FormSuccess fileUploads -> do
|
FormSuccess fileUploads -> do
|
||||||
uid <- requireAuthId
|
uid <- requireAuthId
|
||||||
|
|
||||||
void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
|
||||||
{-case res of
|
case res of
|
||||||
(Left _) -> addMessageI Success MsgRatingFilesUpdated
|
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
|
||||||
(Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected
|
(Just _) -> do
|
||||||
(Right other) -> throw other-}
|
addMessageI Success MsgRatingFilesUpdated
|
||||||
|
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||||
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
|
|
||||||
|
|
||||||
mr <- getMessageRender
|
mr <- getMessageRender
|
||||||
let sheetTypeDesc = mr sheetType
|
let sheetTypeDesc = mr sheetType
|
||||||
@ -620,13 +646,15 @@ postCorrectionsUploadR = do
|
|||||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||||
FormSuccess files -> do
|
FormSuccess files -> do
|
||||||
uid <- requireAuthId
|
uid <- requireAuthId
|
||||||
subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
|
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
|
||||||
if
|
case mbSubs of
|
||||||
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
Nothing -> return ()
|
||||||
| otherwise -> do
|
(Just subs)
|
||||||
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
|
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
|
||||||
mr <- (toHtml .) <$> getMessageRender
|
| otherwise -> do
|
||||||
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
|
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
|
||||||
|
mr <- (toHtml .) <$> getMessageRender
|
||||||
|
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
|
||||||
|
|
||||||
|
|
||||||
defaultLayout $
|
defaultLayout $
|
||||||
@ -794,14 +822,17 @@ postCorrectionsGradeR = do
|
|||||||
, colCommentField
|
, colCommentField
|
||||||
] -- Continue here
|
] -- Continue here
|
||||||
psValidator = def
|
psValidator = def
|
||||||
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
|
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
|
||||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||||
|
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
|
||||||
|
cID <- encrypt subId
|
||||||
|
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
||||||
|
return i
|
||||||
|
|
||||||
tableForm <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
|
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def
|
||||||
cID <- encrypt subId
|
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
|
||||||
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
, dbParamsFormAddSubmit = True
|
||||||
return i
|
}
|
||||||
((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
|
|
||||||
|
|
||||||
case tableRes of
|
case tableRes of
|
||||||
FormMissing -> return ()
|
FormMissing -> return ()
|
||||||
|
|||||||
@ -1,23 +1,25 @@
|
|||||||
module Handler.Course where
|
module Handler.Course where
|
||||||
|
|
||||||
import Import hiding (catMaybes)
|
import Import
|
||||||
|
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
-- import Utils.DB
|
-- import Utils.DB
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
import Handler.Utils.Course
|
||||||
|
import Handler.Utils.Delete
|
||||||
|
|
||||||
-- import Data.Time
|
-- import Data.Time
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Function ((&))
|
import Data.Function ((&))
|
||||||
-- import Yesod.Form.Bootstrap3
|
-- import Yesod.Form.Bootstrap3
|
||||||
|
|
||||||
import Data.Maybe
|
import Data.Monoid (Last(..))
|
||||||
|
|
||||||
|
import Data.Maybe (fromJust)
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
@ -124,6 +126,7 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
|
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
|
||||||
snd <$> dbTable psValidator DBTable
|
snd <$> dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||||
, dbtColonnade = colChoices
|
, dbtColonnade = colChoices
|
||||||
, dbtProj
|
, dbtProj
|
||||||
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
|
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
|
||||||
@ -161,13 +164,28 @@ makeCourseTable whereClause colChoices psValidator = do
|
|||||||
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||||
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
|
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
|
||||||
)
|
)
|
||||||
|
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
|
||||||
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||||
|
Just needle -> course2Registered muid tExpr E.==. E.val needle
|
||||||
|
)
|
||||||
|
, ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
|
||||||
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||||
|
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||||
|
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||||
|
E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
||||||
|
)
|
||||||
]
|
]
|
||||||
, dbtStyle = def
|
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
|
||||||
|
[ Just $ Map.singleton "search" . maybeToList <$> aopt (searchField True) (fslI MsgCourseFilterSearch) (Just <$> listToMaybe =<< Map.lookup "search" =<< mPrev)
|
||||||
|
, muid $> (Map.singleton "registered" . fmap toPathPiece . maybeToList <$> aopt boolField (fslI MsgCourseFilterRegistered) (Just <$> fromPathPiece =<< listToMaybe =<< Map.lookup "registered" =<< mPrev))
|
||||||
|
]
|
||||||
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
|
, dbtParams = def
|
||||||
, dbtIdent = "courses" :: Text
|
, dbtIdent = "courses" :: Text
|
||||||
}
|
}
|
||||||
|
|
||||||
getCourseListR :: Handler Html
|
getCourseListR :: Handler Html
|
||||||
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
|
getCourseListR = do
|
||||||
muid <- maybeAuthId
|
muid <- maybeAuthId
|
||||||
let colonnade = widgetColonnade $ mconcat
|
let colonnade = widgetColonnade $ mconcat
|
||||||
[ colCourseDescr
|
[ colCourseDescr
|
||||||
@ -178,11 +196,10 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
|
|||||||
]
|
]
|
||||||
whereClause = const $ E.val True
|
whereClause = const $ E.val True
|
||||||
validator = def
|
validator = def
|
||||||
& defaultSorting [("course", SortAsc), ("term", SortDesc)]
|
& defaultSorting [SortAscBy "course", SortDescBy "term"]
|
||||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI MsgCourseListTitle
|
setTitleI MsgCourseListTitle
|
||||||
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
|
|
||||||
$(widgetFile "courses")
|
$(widgetFile "courses")
|
||||||
|
|
||||||
getTermCurrentR :: Handler Html
|
getTermCurrentR :: Handler Html
|
||||||
@ -210,7 +227,7 @@ getTermSchoolCourseListR tid ssh = do
|
|||||||
course E.^. CourseTerm E.==. E.val tid
|
course E.^. CourseTerm E.==. E.val tid
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||||
validator = def
|
validator = def
|
||||||
& defaultSorting [("cshort", SortAsc)]
|
& defaultSorting [SortAscBy "cshort"]
|
||||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
setTitleI $ MsgTermSchoolCourseListTitle tid school
|
||||||
@ -232,7 +249,7 @@ getTermCourseListR tid = do
|
|||||||
]
|
]
|
||||||
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
|
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
|
||||||
validator = def
|
validator = def
|
||||||
& defaultSorting [("cshort", SortAsc)]
|
& defaultSorting [SortAscBy "cshort"]
|
||||||
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI . MsgTermCourseListTitle $ tid
|
setTitleI . MsgTermCourseListTitle $ tid
|
||||||
@ -299,13 +316,6 @@ postCRegisterR tid ssh csh = do
|
|||||||
redirect $ CourseR tid ssh csh CShowR
|
redirect $ CourseR tid ssh csh CShowR
|
||||||
|
|
||||||
|
|
||||||
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
|
|
||||||
getCourseNewTemplateR mbTid mbSsh mbCsh =
|
|
||||||
redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid
|
|
||||||
, ("ssh",).CI.original.unSchoolKey <$> mbSsh
|
|
||||||
, ("csh",).CI.original <$> mbCsh
|
|
||||||
])
|
|
||||||
|
|
||||||
getCourseNewR :: Handler Html -- call via toTextUrl
|
getCourseNewR :: Handler Html -- call via toTextUrl
|
||||||
getCourseNewR = do
|
getCourseNewR = do
|
||||||
uid <- requireAuthId
|
uid <- requireAuthId
|
||||||
@ -378,18 +388,14 @@ pgCEditR isGetReq tid ssh csh = do
|
|||||||
courseEditHandler isGetReq $ courseToForm <$> course
|
courseEditHandler isGetReq $ courseToForm <$> course
|
||||||
|
|
||||||
|
|
||||||
getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||||
getCDeleteR = error "TODO: implement getCDeleteR"
|
getCDeleteR = postCDeleteR
|
||||||
postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
postCDeleteR tid ssh csh = do
|
||||||
postCDeleteR = error "TODO: implement getCDeleteR"
|
Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
{- TODO
|
deleteR $ (courseDeleteRoute $ Set.singleton cId)
|
||||||
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
|
{ drAbort = SomeRoute $ CourseR tid ssh csh CShowR
|
||||||
, Just cid <- cfCourseId res -> do
|
, drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
|
||||||
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
}
|
||||||
let cti = toPathPiece $ cfTerm res
|
|
||||||
addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
|
||||||
redirect $ TermCourseListR $ cfTerm res
|
|
||||||
-}
|
|
||||||
|
|
||||||
|
|
||||||
-- | Course Creation and Editing
|
-- | Course Creation and Editing
|
||||||
|
|||||||
@ -75,6 +75,7 @@ homeAnonymous = do
|
|||||||
]
|
]
|
||||||
courseTable <- runDB $ dbTableWidget' def DBTable
|
courseTable <- runDB $ dbTableWidget' def DBTable
|
||||||
{ dbtSQLQuery = tableData
|
{ dbtSQLQuery = tableData
|
||||||
|
, dbtRowKey = (E.^. CourseId)
|
||||||
, dbtColonnade = colonnade
|
, dbtColonnade = colonnade
|
||||||
, dbtProj = return
|
, dbtProj = return
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
@ -97,7 +98,9 @@ homeAnonymous = do
|
|||||||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||||||
)
|
)
|
||||||
] -}
|
] -}
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams = def
|
||||||
, dbtIdent = "upcomingdeadlines" :: Text
|
, dbtIdent = "upcomingdeadlines" :: Text
|
||||||
}
|
}
|
||||||
-- let features = $(widgetFile "featureList")
|
-- let features = $(widgetFile "featureList")
|
||||||
@ -166,9 +169,10 @@ homeUser uid = do
|
|||||||
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
||||||
tickmark
|
tickmark
|
||||||
]
|
]
|
||||||
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
|
let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
|
||||||
sheetTable <- runDB $ dbTableWidget' validator DBTable
|
sheetTable <- runDB $ dbTableWidget' validator DBTable
|
||||||
{ dbtSQLQuery = tableData
|
{ dbtSQLQuery = tableData
|
||||||
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||||
, dbtColonnade = colonnade
|
, dbtColonnade = colonnade
|
||||||
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
||||||
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
||||||
@ -198,7 +202,9 @@ homeUser uid = do
|
|||||||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||||||
)
|
)
|
||||||
] -}
|
] -}
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
||||||
|
, dbtParams = def
|
||||||
, dbtIdent = "upcomingdeadlines" :: Text
|
, dbtIdent = "upcomingdeadlines" :: Text
|
||||||
}
|
}
|
||||||
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
||||||
@ -284,7 +290,11 @@ getAuthPredsR = postAuthPredsR
|
|||||||
postAuthPredsR = do
|
postAuthPredsR = do
|
||||||
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
||||||
|
|
||||||
let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
|
let
|
||||||
|
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
|
||||||
|
taForm authTag
|
||||||
|
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
|
||||||
|
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
|
||||||
|
|
||||||
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
|
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
|
||||||
$ AuthTagActive
|
$ AuthTagActive
|
||||||
|
|||||||
@ -106,9 +106,9 @@ postProfileDataR = do
|
|||||||
defaultLayout
|
defaultLayout
|
||||||
$(widgetFile "deletedUser")
|
$(widgetFile "deletedUser")
|
||||||
|
|
||||||
(FormSuccess BtnAbort ) -> do
|
-- (FormSuccess BtnAbort ) -> do
|
||||||
addMessageI Info MsgAborted
|
-- addMessageI Info MsgAborted
|
||||||
redirect ProfileDataR
|
-- redirect ProfileDataR
|
||||||
_other -> getProfileDataR
|
_other -> getProfileDataR
|
||||||
|
|
||||||
|
|
||||||
@ -247,6 +247,7 @@ mkOwnedCoursesTable =
|
|||||||
, course E.^. CourseSchool
|
, course E.^. CourseSchool
|
||||||
, course E.^. CourseShorthand
|
, course E.^. CourseShorthand
|
||||||
)
|
)
|
||||||
|
dbtRowKey (course `E.InnerJoin` _) = course E.^. CourseId
|
||||||
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
|
dbtProj = return . (_dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh)))
|
||||||
|
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
@ -262,7 +263,7 @@ mkOwnedCoursesTable =
|
|||||||
courseCellCL <$> view _dbrOutput
|
courseCellCL <$> view _dbrOutput
|
||||||
]
|
]
|
||||||
|
|
||||||
validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ]
|
validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
|
||||||
dbtSorting = Map.fromList
|
dbtSorting = Map.fromList
|
||||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
||||||
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
||||||
@ -273,6 +274,8 @@ mkOwnedCoursesTable =
|
|||||||
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
||||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||||
]
|
]
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def
|
||||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> dbTableWidget validator DBTable{..}
|
||||||
|
|
||||||
|
|
||||||
@ -284,7 +287,7 @@ mkEnrolledCoursesTable =
|
|||||||
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
|
||||||
withType = id
|
withType = id
|
||||||
|
|
||||||
validator = def & defaultSorting [("time",SortDesc)]
|
validator = def & defaultSorting [SortDescBy "time"]
|
||||||
|
|
||||||
in \uid -> dbTableWidget' validator
|
in \uid -> dbTableWidget' validator
|
||||||
DBTable
|
DBTable
|
||||||
@ -293,6 +296,7 @@ mkEnrolledCoursesTable =
|
|||||||
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
||||||
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
||||||
return (course, participant E.^. CourseParticipantRegistration)
|
return (course, participant E.^. CourseParticipantRegistration)
|
||||||
|
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
|
||||||
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
|
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
|
||||||
, dbtColonnade = mconcat
|
, dbtColonnade = mconcat
|
||||||
[ dbRow
|
[ dbRow
|
||||||
@ -319,7 +323,9 @@ mkEnrolledCoursesTable =
|
|||||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
|
||||||
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
|
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
|
||||||
]
|
]
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams = def
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@ -345,6 +351,7 @@ mkSubmissionTable =
|
|||||||
)
|
)
|
||||||
let sht = sheet E.^. SheetName
|
let sht = sheet E.^. SheetName
|
||||||
return (crse, sht, submission, lastSubEdit uid submission)
|
return (crse, sht, submission, lastSubEdit uid submission)
|
||||||
|
dbtRowKey (_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) = submission E.^. SubmissionId
|
||||||
|
|
||||||
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
lastSubEdit uid submission = -- latest Edit-Time of this user for submission
|
||||||
E.sub_select . E.from $ \subEdit -> do
|
E.sub_select . E.from $ \subEdit -> do
|
||||||
@ -383,7 +390,7 @@ mkSubmissionTable =
|
|||||||
validator = def -- DUPLICATED CODE: Handler.Corrections
|
validator = def -- DUPLICATED CODE: Handler.Corrections
|
||||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||||
& restrictSorting (\name _ -> name /= "corrector")
|
& restrictSorting (\name _ -> name /= "corrector")
|
||||||
& defaultSorting [("edit",SortDesc)]
|
& defaultSorting [SortDescBy "edit"]
|
||||||
dbtSorting' uid = Map.fromList
|
dbtSorting' uid = Map.fromList
|
||||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
|
||||||
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm )
|
||||||
@ -396,6 +403,8 @@ mkSubmissionTable =
|
|||||||
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
||||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||||
]
|
]
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def
|
||||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||||
dbtSorting = dbtSorting' uid
|
dbtSorting = dbtSorting' uid
|
||||||
in dbTableWidget' validator DBTable{..}
|
in dbTableWidget' validator DBTable{..}
|
||||||
@ -423,6 +432,7 @@ mkSubmissionGroupTable =
|
|||||||
, course E.^. CourseShorthand
|
, course E.^. CourseShorthand
|
||||||
)
|
)
|
||||||
return (crse, sgroup, lastSGEdit sgroup)
|
return (crse, sgroup, lastSGEdit sgroup)
|
||||||
|
dbtRowKey (_ `E.InnerJoin` sgroup `E.InnerJoin` _) = sgroup E.^. SubmissionGroupId
|
||||||
|
|
||||||
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
|
lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
|
||||||
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
|
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
|
||||||
@ -452,7 +462,7 @@ mkSubmissionGroupTable =
|
|||||||
validator = def -- DUPLICATED CODE: Handler.Corrections
|
validator = def -- DUPLICATED CODE: Handler.Corrections
|
||||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||||
& restrictSorting (\name _ -> name /= "corrector")
|
& restrictSorting (\name _ -> name /= "corrector")
|
||||||
& defaultSorting [("edit",SortDesc)]
|
& defaultSorting [SortDescBy "edit"]
|
||||||
dbtSorting = Map.fromList
|
dbtSorting = Map.fromList
|
||||||
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
|
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
|
||||||
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
||||||
@ -465,6 +475,8 @@ mkSubmissionGroupTable =
|
|||||||
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
|
||||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||||
]
|
]
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def
|
||||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||||
in dbTableWidget' validator DBTable{..}
|
in dbTableWidget' validator DBTable{..}
|
||||||
|
|
||||||
@ -500,6 +512,7 @@ mkCorrectionsTable =
|
|||||||
, course E.^. CourseShorthand
|
, course E.^. CourseShorthand
|
||||||
)
|
)
|
||||||
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
|
||||||
|
dbtRowKey (_ `E.InnerJoin` sheet `E.InnerJoin` _) = sheet E.^. SheetId
|
||||||
|
|
||||||
dbtProj x = return $ x
|
dbtProj x = return $ x
|
||||||
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
& _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
|
||||||
@ -525,7 +538,7 @@ mkCorrectionsTable =
|
|||||||
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
|
int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
|
||||||
]
|
]
|
||||||
|
|
||||||
validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
|
validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"]
|
||||||
dbtSorting = Map.fromList
|
dbtSorting = Map.fromList
|
||||||
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
|
||||||
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
|
, ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool )
|
||||||
@ -538,6 +551,8 @@ mkCorrectionsTable =
|
|||||||
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
|
||||||
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
|
||||||
]
|
]
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtParams = def
|
||||||
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
|
||||||
in dbTableWidget' validator DBTable{..}
|
in dbTableWidget' validator DBTable{..}
|
||||||
|
|
||||||
|
|||||||
@ -7,6 +7,7 @@ import Handler.Utils
|
|||||||
-- import Handler.Utils.Zip
|
-- import Handler.Utils.Zip
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
import Handler.Utils.SheetType
|
import Handler.Utils.SheetType
|
||||||
|
import Handler.Utils.Delete
|
||||||
|
|
||||||
-- import Data.Time
|
-- import Data.Time
|
||||||
-- import qualified Data.Text as T
|
-- import qualified Data.Text as T
|
||||||
@ -146,13 +147,17 @@ getSheetListR tid ssh csh = do
|
|||||||
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
||||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||||
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
|
|
||||||
|
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
|
||||||
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
||||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
||||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||||
return (sheet, lastSheetEdit sheet, submission)
|
|
||||||
|
sheetFilter :: SheetName -> DB Bool
|
||||||
|
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
|
||||||
|
|
||||||
sheetCol = widgetColonnade . mconcat $
|
sheetCol = widgetColonnade . mconcat $
|
||||||
[ dbRow
|
[ dbRow
|
||||||
, sortable (Just "name") (i18nCell MsgSheet)
|
, sortable (Just "name") (i18nCell MsgSheet)
|
||||||
@ -195,50 +200,59 @@ getSheetListR tid ssh csh = do
|
|||||||
_other -> mempty
|
_other -> mempty
|
||||||
_other -> mempty
|
_other -> mempty
|
||||||
]
|
]
|
||||||
|
|
||||||
psValidator = def
|
psValidator = def
|
||||||
& defaultSorting [("submission-since", SortAsc)]
|
& defaultSorting [SortDescBy "submission-since"]
|
||||||
table <- runDB $ dbTableWidget' psValidator DBTable
|
|
||||||
{ dbtSQLQuery = sheetData
|
(table,raw_statistics) <- runDB $ liftA2 (,)
|
||||||
, dbtColonnade = sheetCol
|
(dbTableWidget' psValidator DBTable
|
||||||
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
{ dbtColonnade = sheetCol
|
||||||
-> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
|
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
|
||||||
, dbtSorting = Map.fromList
|
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
|
||||||
[ ( "name"
|
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
||||||
)
|
-> dbr <$ guardM (lift $ sheetFilter sheetName)
|
||||||
, ( "last-edit"
|
, dbtSorting = Map.fromList
|
||||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
[ ( "name"
|
||||||
)
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||||
, ( "submission-since"
|
)
|
||||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
, ( "last-edit"
|
||||||
)
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
||||||
, ( "submission-until"
|
)
|
||||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
, ( "submission-since"
|
||||||
)
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
||||||
, ( "rating"
|
)
|
||||||
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
, ( "submission-until"
|
||||||
)
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
||||||
-- GitLab Issue $143: HOW TO SORT?
|
)
|
||||||
-- , ( "percent"
|
, ( "rating"
|
||||||
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
||||||
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
)
|
||||||
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
-- GitLab Issue $143: HOW TO SORT?
|
||||||
-- )
|
-- , ( "percent"
|
||||||
]
|
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||||
, dbtFilter = Map.fromList
|
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
||||||
[]
|
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
||||||
, dbtStyle = def
|
-- )
|
||||||
, dbtIdent = "sheets" :: Text
|
]
|
||||||
}
|
, dbtFilter = mempty
|
||||||
-- Collect summary over all Sheets, not just the ones shown due to pagination:
|
, dbtFilterUI = mempty
|
||||||
statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> do
|
, dbtStyle = def
|
||||||
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
|
, dbtParams = def
|
||||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
, dbtIdent = "sheets" :: Text
|
||||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
}
|
||||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
) (
|
||||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
-- Collect summary over all Sheets, not just the ones shown due to pagination:
|
||||||
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
do
|
||||||
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
|
rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||||
|
sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
||||||
|
flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
|
||||||
|
)
|
||||||
|
|
||||||
|
let statistics =
|
||||||
|
gradeSummaryWidget MsgSheetGradingSummaryTitle $
|
||||||
|
foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
|
||||||
|
raw_statistics
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
$(widgetFile "sheetList")
|
$(widgetFile "sheetList")
|
||||||
|
|
||||||
@ -287,14 +301,16 @@ getSShowR tid ssh csh shn = do
|
|||||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
|
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
|
||||||
]
|
]
|
||||||
let psValidator = def
|
let psValidator = def
|
||||||
& defaultSorting [("type", SortAsc), ("path", SortAsc)]
|
& defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery = fileData
|
{ dbtSQLQuery = fileData
|
||||||
|
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
|
||||||
, dbtColonnade = colonnadeFiles
|
, dbtColonnade = colonnadeFiles
|
||||||
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
|
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
|
||||||
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
|
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
, dbtFilter = Map.empty
|
, dbtFilter = mempty
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtIdent = "files" :: Text
|
, dbtIdent = "files" :: Text
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
[ ( "type"
|
[ ( "type"
|
||||||
@ -307,6 +323,7 @@ getSShowR tid ssh csh shn = do
|
|||||||
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
|
, dbtParams = def
|
||||||
}
|
}
|
||||||
(hasHints, hasSolution) <- runDB $ do
|
(hasHints, hasSolution) <- runDB $ do
|
||||||
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
||||||
@ -467,20 +484,22 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
|||||||
saveOkay <- runDB $ do
|
saveOkay <- runDB $ do
|
||||||
actTime <- liftIO getCurrentTime
|
actTime <- liftIO getCurrentTime
|
||||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||||
|
oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
|
||||||
let newSheet = Sheet
|
let newSheet = Sheet
|
||||||
{ sheetCourse = cid
|
{ sheetCourse = cid
|
||||||
, sheetName = sfName
|
, sheetName = sfName
|
||||||
, sheetDescription = sfDescription
|
, sheetDescription = sfDescription
|
||||||
, sheetType = sfType
|
, sheetType = sfType
|
||||||
, sheetGrouping = sfGrouping
|
, sheetGrouping = sfGrouping
|
||||||
, sheetMarkingText = sfMarkingText
|
, sheetMarkingText = sfMarkingText
|
||||||
, sheetVisibleFrom = sfVisibleFrom
|
, sheetVisibleFrom = sfVisibleFrom
|
||||||
, sheetActiveFrom = sfActiveFrom
|
, sheetActiveFrom = sfActiveFrom
|
||||||
, sheetActiveTo = sfActiveTo
|
, sheetActiveTo = sfActiveTo
|
||||||
, sheetHintFrom = sfHintFrom
|
, sheetHintFrom = sfHintFrom
|
||||||
, sheetSolutionFrom = sfSolutionFrom
|
, sheetSolutionFrom = sfSolutionFrom
|
||||||
, sheetUploadMode = sfUploadMode
|
, sheetUploadMode = sfUploadMode
|
||||||
, sheetSubmissionMode = sfSubmissionMode
|
, sheetSubmissionMode = sfSubmissionMode
|
||||||
|
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
|
||||||
}
|
}
|
||||||
mbsid <- dbAction newSheet
|
mbsid <- dbAction newSheet
|
||||||
case mbsid of
|
case mbsid of
|
||||||
@ -512,30 +531,14 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
|||||||
$(widgetFile "formPageI18n")
|
$(widgetFile "formPageI18n")
|
||||||
|
|
||||||
|
|
||||||
|
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||||
getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
getSDelR = postSDelR
|
||||||
getSDelR tid ssh csh shn = do
|
postSDelR tid ssh csh shn = do
|
||||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
sid <- runDB $ fetchSheetId tid ssh csh shn
|
||||||
case result of
|
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
|
||||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
|
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
||||||
(FormSuccess BtnDelete) -> do
|
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
|
||||||
runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
|
}
|
||||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
|
||||||
addMessageI Info $ MsgSheetDelOk tid ssh csh shn
|
|
||||||
redirect $ CourseR tid ssh csh SheetListR
|
|
||||||
_other -> do
|
|
||||||
submissionno <- runDB $ do
|
|
||||||
sid <- fetchSheetId tid ssh csh shn
|
|
||||||
count [SubmissionSheet ==. sid]
|
|
||||||
let formText = Just $ MsgSheetDelText submissionno
|
|
||||||
let actionUrl = CSheetR tid ssh csh shn SDelR
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitleI $ MsgSheetTitle tid ssh csh shn
|
|
||||||
$(widgetFile "formPageI18n")
|
|
||||||
|
|
||||||
postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
||||||
postSDelR = getSDelR
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
||||||
@ -595,7 +598,7 @@ defaultLoads shid = do
|
|||||||
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 uid (state, load)
|
||||||
|
|
||||||
|
|
||||||
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
|
correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
|
||||||
correctorForm shid = do
|
correctorForm shid = do
|
||||||
cListIdent <- newFormIdent
|
cListIdent <- newFormIdent
|
||||||
let
|
let
|
||||||
@ -608,7 +611,7 @@ correctorForm shid = do
|
|||||||
let
|
let
|
||||||
currentLoads :: DB Loads
|
currentLoads :: DB Loads
|
||||||
currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
|
currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
|
||||||
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
|
(autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
|
||||||
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
|
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
|
||||||
| Map.null currentLoads'
|
| Map.null currentLoads'
|
||||||
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
|
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
|
||||||
@ -620,6 +623,7 @@ correctorForm shid = do
|
|||||||
didDelete = any (flip Set.member deletions) formCIDs
|
didDelete = any (flip Set.member deletions) formCIDs
|
||||||
|
|
||||||
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
|
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
|
||||||
|
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
|
||||||
let
|
let
|
||||||
tutorField :: Field Handler [UserEmail]
|
tutorField :: Field Handler [UserEmail]
|
||||||
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
|
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
|
||||||
@ -713,23 +717,25 @@ correctorForm shid = do
|
|||||||
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
|
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
|
||||||
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
|
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
|
||||||
|
|
||||||
return (corrResults, [ countTutView
|
return ( (,) <$> autoDistributeRes <*> corrResults
|
||||||
, FieldView
|
, [ autoDistributeView
|
||||||
{ fvLabel = text $ mr MsgCorrectors
|
, countTutView
|
||||||
, fvTooltip = Nothing
|
, FieldView
|
||||||
, fvId = ""
|
{ fvLabel = text $ mr MsgCorrectors
|
||||||
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
|
, fvTooltip = Nothing
|
||||||
, fvErrors = Nothing
|
, fvId = ""
|
||||||
, fvRequired = True
|
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
|
||||||
}
|
, fvErrors = Nothing
|
||||||
, addTutView
|
, fvRequired = True
|
||||||
{ fvInput = [whamlet|
|
}
|
||||||
<div>
|
, addTutView
|
||||||
^{fvInput addTutView}
|
{ fvInput = [whamlet|
|
||||||
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|
<div>
|
||||||
|]
|
^{fvInput addTutView}
|
||||||
}
|
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|
||||||
])
|
|]
|
||||||
|
}
|
||||||
|
])
|
||||||
|
|
||||||
-- Eingabebox für Korrektor hinzufügen
|
-- Eingabebox für Korrektor hinzufügen
|
||||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||||
@ -743,7 +749,8 @@ getSCorrR tid ssh csh shn = do
|
|||||||
|
|
||||||
case res of
|
case res of
|
||||||
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
|
||||||
FormSuccess res' -> runDB $ do
|
FormSuccess (autoDistribute, res') -> runDB $ do
|
||||||
|
update shid [ SheetAutoDistribute =. autoDistribute ]
|
||||||
deleteWhere [SheetCorrectorSheet ==. shid]
|
deleteWhere [SheetCorrectorSheet ==. shid]
|
||||||
insertMany_ $ Set.toList res'
|
insertMany_ $ Set.toList res'
|
||||||
addMessageI Success MsgCorrectorsUpdated
|
addMessageI Success MsgCorrectorsUpdated
|
||||||
|
|||||||
@ -7,6 +7,7 @@ import Jobs
|
|||||||
-- import Yesod.Form.Bootstrap3
|
-- import Yesod.Form.Bootstrap3
|
||||||
|
|
||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
|
import Handler.Utils.Delete
|
||||||
import Handler.Utils.Submission
|
import Handler.Utils.Submission
|
||||||
import Handler.Utils.Table.Cells
|
import Handler.Utils.Table.Cells
|
||||||
|
|
||||||
@ -169,7 +170,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
|||||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||||
return (csheet,buddies,lastEdits)
|
return (csheet,buddies,lastEdits)
|
||||||
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
|
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
|
||||||
mCID <- runDBJobs $ do
|
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
|
||||||
res' <- case res of
|
res' <- case res of
|
||||||
FormMissing -> return FormMissing
|
FormMissing -> return FormMissing
|
||||||
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
||||||
@ -298,6 +299,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
|||||||
return ((sf1, f1), (sf2, f2))
|
return ((sf1, f1), (sf2, f2))
|
||||||
smid2ArchiveTable (smid,cid) = DBTable
|
smid2ArchiveTable (smid,cid) = DBTable
|
||||||
{ dbtSQLQuery = submissionFiles smid
|
{ dbtSQLQuery = submissionFiles smid
|
||||||
|
, dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
|
||||||
, dbtColonnade = colonnadeFiles cid
|
, dbtColonnade = colonnadeFiles cid
|
||||||
, dbtProj = return . dbrOutput
|
, dbtProj = return . dbrOutput
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
@ -310,7 +312,9 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
|
|||||||
, SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
|
, SortColumn $ \((_sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (_sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilter = Map.empty
|
, dbtFilter = mempty
|
||||||
|
, dbtFilterUI = mempty
|
||||||
|
, dbtParams = def
|
||||||
}
|
}
|
||||||
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
|
||||||
|
|
||||||
@ -387,3 +391,12 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
|
|||||||
zipComment = Text.encodeUtf8 $ toPathPiece cID
|
zipComment = Text.encodeUtf8 $ toPathPiece cID
|
||||||
|
|
||||||
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||||
|
|
||||||
|
getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||||
|
getSubDelR = postSubDelR
|
||||||
|
postSubDelR tid ssh csh shn cID = do
|
||||||
|
subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID
|
||||||
|
deleteR $ (submissionDeleteRoute $ Set.singleton subId)
|
||||||
|
{ drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||||
|
, drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
||||||
|
}
|
||||||
|
|||||||
@ -13,6 +13,8 @@ import Handler.Utils
|
|||||||
|
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
htmlField' :: Field (HandlerT UniWorX IO) Html
|
htmlField' :: Field (HandlerT UniWorX IO) Html
|
||||||
htmlField' = htmlField
|
htmlField' = htmlField
|
||||||
@ -57,7 +59,7 @@ postMessageR cID = do
|
|||||||
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
|
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
|
||||||
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
|
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
|
||||||
)
|
)
|
||||||
<*> combinedButtonField (universeF :: [BtnSubmitDelete])
|
<*> combinedButtonFieldF ""
|
||||||
|
|
||||||
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
|
||||||
|
|
||||||
@ -154,7 +156,7 @@ postMessageListR = do
|
|||||||
let
|
let
|
||||||
dbtSQLQuery = return
|
dbtSQLQuery = return
|
||||||
dbtColonnade = mconcat
|
dbtColonnade = mconcat
|
||||||
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
[ dbSelect _2 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
|
||||||
, dbRow
|
, dbRow
|
||||||
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
|
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext)
|
||||||
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
|
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
|
||||||
@ -173,31 +175,47 @@ postMessageListR = do
|
|||||||
{ dbrOutput = (smE, smT)
|
{ dbrOutput = (smE, smT)
|
||||||
, ..
|
, ..
|
||||||
}
|
}
|
||||||
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
|
||||||
tableForm <- runDB $ dbTable psValidator DBTable
|
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery
|
{ dbtSQLQuery
|
||||||
|
, dbtRowKey = (E.^. SystemMessageId)
|
||||||
, dbtColonnade
|
, dbtColonnade
|
||||||
, dbtProj
|
, dbtProj
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
[ -- TODO: from, to, authenticated, severity
|
[ ( "from"
|
||||||
]
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
|
||||||
, dbtFilter = Map.fromList
|
)
|
||||||
[
|
, ( "to"
|
||||||
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
|
||||||
|
)
|
||||||
|
, ( "authenticated"
|
||||||
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
|
||||||
|
)
|
||||||
|
, ( "severity"
|
||||||
|
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
|
||||||
|
)
|
||||||
]
|
]
|
||||||
|
, dbtFilter = mempty
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams = def
|
||||||
|
{ dbParamsFormAction = Just $ SomeRoute MessageListR
|
||||||
|
, dbParamsFormAddSubmit = True
|
||||||
|
, dbParamsFormAdditional = \frag -> do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
let actions = Map.fromList
|
||||||
|
[ (SMDelete, pure SMDDelete)
|
||||||
|
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
|
||||||
|
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
|
||||||
|
]
|
||||||
|
(actionRes, action) <- multiAction actions (Just SMActivate)
|
||||||
|
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
|
||||||
|
}
|
||||||
, dbtIdent = "messages" :: Text
|
, dbtIdent = "messages" :: Text
|
||||||
}
|
}
|
||||||
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
|
|
||||||
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
|
let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
|
||||||
now <- liftIO getCurrentTime
|
& mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
|
||||||
let actions = Map.fromList
|
|
||||||
[ (SMDelete, pure SMDDelete)
|
|
||||||
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
|
|
||||||
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
|
|
||||||
]
|
|
||||||
(actionRes, action) <- multiAction actions (Just SMActivate)
|
|
||||||
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
|
|
||||||
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
|
||||||
|
|
||||||
case tableRes of
|
case tableRes of
|
||||||
FormMissing -> return ()
|
FormMissing -> return ()
|
||||||
|
|||||||
@ -98,6 +98,7 @@ getTermShowR = do
|
|||||||
-- ]
|
-- ]
|
||||||
table <- runDB $ dbTableWidget' def DBTable
|
table <- runDB $ dbTableWidget' def DBTable
|
||||||
{ dbtSQLQuery = termData
|
{ dbtSQLQuery = termData
|
||||||
|
, dbtRowKey = (E.^. TermId)
|
||||||
, dbtColonnade = colonnadeTerms
|
, dbtColonnade = colonnadeTerms
|
||||||
, dbtProj = return . dbrOutput
|
, dbtProj = return . dbrOutput
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
@ -126,7 +127,9 @@ getTermShowR = do
|
|||||||
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
|
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
|
||||||
)
|
)
|
||||||
]
|
]
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams = def
|
||||||
, dbtIdent = "terms" :: Text
|
, dbtIdent = "terms" :: Text
|
||||||
}
|
}
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
|
|||||||
@ -9,18 +9,16 @@ import Utils.Lens
|
|||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Set as Set
|
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
hijackUserForm :: UserId -> Form UserId
|
hijackUserForm :: CryptoUUIDUser -> Form ()
|
||||||
hijackUserForm uid csrf = do
|
hijackUserForm cID csrf = do
|
||||||
cID <- encrypt uid
|
|
||||||
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
|
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
|
||||||
(btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
|
(btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing
|
||||||
|
|
||||||
return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
|
return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
|
||||||
|
|
||||||
getUsersR :: Handler Html
|
getUsersR :: Handler Html
|
||||||
getUsersR = do
|
getUsersR = do
|
||||||
@ -59,18 +57,22 @@ getUsersR = do
|
|||||||
<li>#{sh}
|
<li>#{sh}
|
||||||
|]
|
|]
|
||||||
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
|
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
|
||||||
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
|
|
||||||
cID <- encrypt uid
|
cID <- encrypt uid
|
||||||
[whamlet|
|
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||||
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
|
myUid <- liftHandlerT maybeAuthId
|
||||||
^{hijackView}
|
when (mayHijack && Just uid /= myUid) $ do
|
||||||
|]
|
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
|
||||||
|
[whamlet|
|
||||||
|
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
|
||||||
|
^{hijackView}
|
||||||
|
|]
|
||||||
]
|
]
|
||||||
psValidator = def
|
psValidator = def
|
||||||
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
|
& defaultSorting [SortAscBy "name", SortAscBy "display-name"]
|
||||||
|
|
||||||
((), userList) <- runDB $ dbTable psValidator DBTable
|
((), userList) <- runDB $ dbTable psValidator DBTable
|
||||||
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
|
||||||
|
, dbtRowKey = (E.^. UserId)
|
||||||
, dbtColonnade
|
, dbtColonnade
|
||||||
, dbtProj = return
|
, dbtProj = return
|
||||||
, dbtSorting = Map.fromList
|
, dbtSorting = Map.fromList
|
||||||
@ -85,7 +87,9 @@ getUsersR = do
|
|||||||
)
|
)
|
||||||
]
|
]
|
||||||
, dbtFilter = mempty
|
, dbtFilter = mempty
|
||||||
|
, dbtFilterUI = mempty
|
||||||
, dbtStyle = def
|
, dbtStyle = def
|
||||||
|
, dbtParams = def
|
||||||
, dbtIdent = "users" :: Text
|
, dbtIdent = "users" :: Text
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -96,21 +100,10 @@ getUsersR = do
|
|||||||
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
|
||||||
postAdminHijackUserR cID = do
|
postAdminHijackUserR cID = do
|
||||||
uid <- decrypt cID
|
uid <- decrypt cID
|
||||||
((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
|
((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
|
||||||
|
|
||||||
case hijackRes of
|
ret <- formResultMaybe hijackRes $ \() -> Just <$> do
|
||||||
FormSuccess uid'
|
User{userIdent} <- runDB $ get404 uid
|
||||||
| uid' == uid -> do
|
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
||||||
myUid <- requireAuthId
|
|
||||||
User{..} <- runDB $ do
|
|
||||||
otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
|
|
||||||
otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
|
|
||||||
mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
|
|
||||||
unless ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
|
|
||||||
permissionDenied "Cannot escalate admin status to additional schools"
|
|
||||||
|
|
||||||
get404 uid
|
maybe (redirect UsersR) return ret
|
||||||
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
|
|
||||||
| otherwise -> error "This should be impossible by definition of `hijackUserForm`"
|
|
||||||
FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
|
|
||||||
FormMissing -> return $ toTypedContent ()
|
|
||||||
|
|||||||
27
src/Handler/Utils/Course.hs
Normal file
27
src/Handler/Utils/Course.hs
Normal file
@ -0,0 +1,27 @@
|
|||||||
|
module Handler.Utils.Course where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils.Delete
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
|
|
||||||
|
courseDeleteRoute :: Set CourseId -> DeleteRoute Course
|
||||||
|
courseDeleteRoute drRecords = DeleteRoute
|
||||||
|
{ drRecords
|
||||||
|
, drGetInfo = \(course `E.InnerJoin` school) -> do
|
||||||
|
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
|
||||||
|
E.orderBy [E.asc $ course E.^. CourseName]
|
||||||
|
return (course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||||
|
, drUnjoin = \(course `E.InnerJoin` _) -> course
|
||||||
|
, drRenderRecord = \(E.Value cName, _, E.Value sName, E.Value tid') ->
|
||||||
|
return [whamlet|
|
||||||
|
#{cName} (_{ShortTermIdentifier (unTermKey tid')}, #{sName})
|
||||||
|
|]
|
||||||
|
, drRecordConfirmString = \(E.Value cName, E.Value ssh', _, E.Value tid') ->
|
||||||
|
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
|
||||||
|
, drCaption = SomeMessage MsgCourseDeleteQuestion
|
||||||
|
, drSuccessMessage = SomeMessage MsgCourseDeleted
|
||||||
|
, drAbort = error "drAbort undefined"
|
||||||
|
, drSuccess = error "drSuccess undefined"
|
||||||
|
}
|
||||||
102
src/Handler/Utils/Delete.hs
Normal file
102
src/Handler/Utils/Delete.hs
Normal file
@ -0,0 +1,102 @@
|
|||||||
|
module Handler.Utils.Delete
|
||||||
|
( DeleteRoute(..)
|
||||||
|
, deleteR
|
||||||
|
, postDeleteR, getDeleteR
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Handler.Utils.Form
|
||||||
|
|
||||||
|
import Utils.Lens
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
import Data.Char (isAlphaNum)
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
|
||||||
|
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
|
||||||
|
, drRenderRecord :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
||||||
|
, drRecordConfirmString :: info -> ReaderT SqlBackend (HandlerT UniWorX IO) Text
|
||||||
|
, drCaption
|
||||||
|
, drSuccessMessage :: SomeMessage UniWorX
|
||||||
|
, drAbort
|
||||||
|
, drSuccess :: SomeRoute UniWorX
|
||||||
|
}
|
||||||
|
|
||||||
|
confirmForm :: ( MonadHandler m, HandlerSite m ~ UniWorX )
|
||||||
|
=> Text -- ^ Confirmation string
|
||||||
|
-> AForm m Bool
|
||||||
|
confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelete) -> if
|
||||||
|
| ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
|
||||||
|
-> return $ pure True
|
||||||
|
| otherwise
|
||||||
|
-> formFailure [MsgDeleteConfirmationWrong]
|
||||||
|
where
|
||||||
|
aform = (,)
|
||||||
|
<$> areq confirmField (fslI MsgDeleteConfirmation) Nothing
|
||||||
|
<*> disambiguateButtons (combinedButtonFieldF "")
|
||||||
|
confirmField
|
||||||
|
| multiple = convertField unTextarea Textarea textareaField
|
||||||
|
| otherwise = textField
|
||||||
|
multiple = length (filter (not . Text.null . Text.strip) $ Text.lines confirmString) > 1
|
||||||
|
|
||||||
|
confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
|
||||||
|
confirmForm' drRecords confirmString = addDeleteTargets . identForm FIDDelete . renderAForm FormStandard $ confirmForm confirmString
|
||||||
|
where
|
||||||
|
addDeleteTargets :: Form a -> Form a
|
||||||
|
addDeleteTargets form csrf = do
|
||||||
|
(_, fvTargets) <- mreq secretJsonField ("" & addName (toPathPiece PostDeleteTarget)) (Just drRecords)
|
||||||
|
over _2 (mappend $ fvInput fvTargets) <$> form csrf
|
||||||
|
|
||||||
|
|
||||||
|
postDeleteR :: ( DeleteCascade record SqlBackend )
|
||||||
|
=> (Set (Key record) -> DeleteRoute record) -- ^ Construct `DeleteRoute` based on incoming record keys
|
||||||
|
-> Handler ()
|
||||||
|
-- | Perform deletion
|
||||||
|
postDeleteR mkRoute = do
|
||||||
|
drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
|
||||||
|
|
||||||
|
void . for drResult $ \DeleteRoute{..} -> do
|
||||||
|
confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
|
||||||
|
|
||||||
|
((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
|
||||||
|
|
||||||
|
formResult confirmRes $ \case
|
||||||
|
True -> do
|
||||||
|
runDB $ do
|
||||||
|
forM_ drRecords deleteCascade
|
||||||
|
addMessageI Success drSuccessMessage
|
||||||
|
redirect drSuccess
|
||||||
|
False ->
|
||||||
|
redirect drAbort
|
||||||
|
|
||||||
|
|
||||||
|
getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
|
||||||
|
getDeleteR DeleteRoute{..} = do
|
||||||
|
targets <- runDB $ mapM (\i -> (,) <$> drRenderRecord i <*> drRecordConfirmString i) <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
|
||||||
|
|
||||||
|
let confirmString = Text.unlines $ view _2 <$> targets
|
||||||
|
|
||||||
|
(deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
|
||||||
|
|
||||||
|
Just targetRoute <- getCurrentRoute
|
||||||
|
|
||||||
|
sendResponse =<<
|
||||||
|
defaultLayout $(widgetFile "widgets/delete-confirmation")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
deleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler Html
|
||||||
|
deleteR dr = do
|
||||||
|
postDeleteR $ \drRecords -> dr {drRecords}
|
||||||
|
getDeleteR dr
|
||||||
@ -23,8 +23,6 @@ import qualified Data.Text as T
|
|||||||
import Yesod.Form.Functions (parseHelper)
|
import Yesod.Form.Functions (parseHelper)
|
||||||
import Yesod.Form.Bootstrap3
|
import Yesod.Form.Bootstrap3
|
||||||
|
|
||||||
import Web.PathPieces (showToPathPiece, readFromPathPiece)
|
|
||||||
|
|
||||||
import Handler.Utils.Zip
|
import Handler.Utils.Zip
|
||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
|
|
||||||
@ -37,6 +35,7 @@ import Data.Map (Map, (!))
|
|||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
import Control.Monad.Trans.Writer (execWriterT, WriterT)
|
import Control.Monad.Trans.Writer (execWriterT, WriterT)
|
||||||
|
import Control.Monad.Except (runExceptT)
|
||||||
import Control.Monad.Writer.Class
|
import Control.Monad.Writer.Class
|
||||||
|
|
||||||
import Data.Scientific (Scientific)
|
import Data.Scientific (Scientific)
|
||||||
@ -45,30 +44,33 @@ import Text.Read (readMaybe)
|
|||||||
|
|
||||||
import Utils.Lens
|
import Utils.Lens
|
||||||
|
|
||||||
|
import Data.Aeson (eitherDecodeStrict')
|
||||||
|
import Data.Aeson.Text (encodeToLazyText)
|
||||||
|
|
||||||
----------------------------
|
----------------------------
|
||||||
-- Buttons (new version ) --
|
-- Buttons (new version ) --
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
||||||
data BtnDelete = BtnDelete | BtnAbort
|
data BtnDelete = BtnDelete
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||||
|
|
||||||
instance PathPiece BtnDelete where -- for displaying the button only, not really for paths
|
instance Universe BtnDelete
|
||||||
toPathPiece = showToPathPiece
|
instance Finite BtnDelete
|
||||||
fromPathPiece = readFromPathPiece
|
|
||||||
|
nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
|
||||||
|
|
||||||
instance Button UniWorX BtnDelete where
|
instance Button UniWorX BtnDelete where
|
||||||
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
|
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
|
||||||
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
|
|
||||||
|
|
||||||
cssClass BtnDelete = BCDanger
|
cssClass BtnDelete = BCDanger
|
||||||
cssClass BtnAbort = BCDefault
|
|
||||||
|
|
||||||
data RegisterButton = BtnRegister | BtnDeregister
|
data RegisterButton = BtnRegister | BtnDeregister
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||||
|
|
||||||
instance PathPiece RegisterButton where
|
instance Universe RegisterButton
|
||||||
toPathPiece = showToPathPiece
|
instance Finite RegisterButton
|
||||||
fromPathPiece = readFromPathPiece
|
|
||||||
|
nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
|
||||||
|
|
||||||
instance Button UniWorX RegisterButton where
|
instance Button UniWorX RegisterButton where
|
||||||
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
|
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
|
||||||
@ -80,9 +82,10 @@ instance Button UniWorX RegisterButton where
|
|||||||
data AdminHijackUserButton = BtnHijack
|
data AdminHijackUserButton = BtnHijack
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||||
|
|
||||||
instance PathPiece AdminHijackUserButton where
|
instance Universe AdminHijackUserButton
|
||||||
toPathPiece = showToPathPiece
|
instance Finite AdminHijackUserButton
|
||||||
fromPathPiece = readFromPathPiece
|
|
||||||
|
nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
|
||||||
|
|
||||||
instance Button UniWorX AdminHijackUserButton where
|
instance Button UniWorX AdminHijackUserButton where
|
||||||
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
|
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
|
||||||
@ -102,7 +105,10 @@ instance Button UniWorX BtnSubmitDelete where
|
|||||||
cssClass BtnSubmit' = BCPrimary
|
cssClass BtnSubmit' = BCPrimary
|
||||||
cssClass BtnDelete' = BCDanger
|
cssClass BtnDelete' = BCDanger
|
||||||
|
|
||||||
nullaryPathPiece ''BtnSubmitDelete (camelToPathPiece' 1 . dropSuffix "'")
|
btnValidate _ BtnSubmit' = True
|
||||||
|
btnValidate _ BtnDelete' = False
|
||||||
|
|
||||||
|
nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
|
||||||
|
|
||||||
|
|
||||||
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
|
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
|
||||||
@ -312,7 +318,7 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
|
|||||||
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
||||||
|
|
||||||
|
|
||||||
data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
|
data SheetType' = Normal' | Bonus' | Informational' | NotGraded'
|
||||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||||
|
|
||||||
instance Universe SheetType'
|
instance Universe SheetType'
|
||||||
@ -353,8 +359,8 @@ sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler S
|
|||||||
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
|
||||||
where
|
where
|
||||||
selOptions = Map.fromList
|
selOptions = Map.fromList
|
||||||
[ ( Bonus' , Bonus <$> gradingReq )
|
[ ( Normal', Normal <$> gradingReq )
|
||||||
, ( Normal', Normal <$> gradingReq )
|
, ( Bonus' , Bonus <$> gradingReq )
|
||||||
, ( Informational', Informational <$> gradingReq )
|
, ( Informational', Informational <$> gradingReq )
|
||||||
, ( NotGraded', pure NotGraded )
|
, ( NotGraded', pure NotGraded )
|
||||||
]
|
]
|
||||||
@ -455,6 +461,44 @@ langField :: Bool -- ^ Only allow values from `appLanguages`
|
|||||||
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
|
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
|
||||||
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
|
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
|
||||||
|
|
||||||
|
jsonField :: ( ToJSON a, FromJSON a
|
||||||
|
, MonadHandler m
|
||||||
|
, RenderMessage (HandlerSite m) UniWorXMessage
|
||||||
|
, RenderMessage (HandlerSite m) FormMessage
|
||||||
|
)
|
||||||
|
=> Bool {-^ Hidden? -}
|
||||||
|
-> Field m a
|
||||||
|
jsonField hide = Field{..}
|
||||||
|
where
|
||||||
|
inputType :: Text
|
||||||
|
inputType
|
||||||
|
| hide = "hidden"
|
||||||
|
| otherwise = "text"
|
||||||
|
fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
|
||||||
|
fieldParse [] [] = return $ Right Nothing
|
||||||
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||||
|
fieldView theId name attrs val isReq = liftWidgetT [whamlet|
|
||||||
|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
|
||||||
|
|]
|
||||||
|
fieldEnctype = UrlEncoded
|
||||||
|
|
||||||
|
secretJsonField :: ( ToJSON a, FromJSON a
|
||||||
|
, MonadHandler m
|
||||||
|
, HandlerSite m ~ UniWorX
|
||||||
|
)
|
||||||
|
=> Field m a
|
||||||
|
secretJsonField = Field{..}
|
||||||
|
where
|
||||||
|
fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
||||||
|
fieldParse [] [] = return $ Right Nothing
|
||||||
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||||
|
fieldView theId name attrs val _isReq = do
|
||||||
|
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
||||||
|
[whamlet|
|
||||||
|
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||||
|
|]
|
||||||
|
fieldEnctype = UrlEncoded
|
||||||
|
|
||||||
|
|
||||||
funcForm :: forall k v m.
|
funcForm :: forall k v m.
|
||||||
( Finite k, Ord k
|
( Finite k, Ord k
|
||||||
|
|||||||
@ -1,13 +1,12 @@
|
|||||||
module Handler.Utils.Sheet where
|
module Handler.Utils.Sheet where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
import Handler.Utils.Delete
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
import qualified Database.Esqueleto.Internal.Sql as E
|
import qualified Database.Esqueleto.Internal.Sql as E
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||||
, E.SqlSelect b a
|
, E.SqlSelect b a
|
||||||
, Typeable a, MonadHandler m, IsPersistBackend backend
|
, Typeable a, MonadHandler m, IsPersistBackend backend
|
||||||
@ -41,3 +40,31 @@ fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ss
|
|||||||
|
|
||||||
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
|
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 ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
|
||||||
|
|
||||||
|
|
||||||
|
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
|
||||||
|
sheetDeleteRoute drRecords = DeleteRoute
|
||||||
|
{ drRecords
|
||||||
|
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||||
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||||
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||||
|
let submissions = E.sub_select . E.from $ \submission -> do
|
||||||
|
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||||
|
return E.countRows
|
||||||
|
E.orderBy [E.asc $ sheet E.^. SheetName]
|
||||||
|
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||||
|
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
|
||||||
|
, drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
|
||||||
|
return [whamlet|
|
||||||
|
$newline never
|
||||||
|
#{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
|
||||||
|
$if submissions /= 0
|
||||||
|
<i>_{SomeMessage $ MsgSheetDelHasSubmissions submissions}
|
||||||
|
|]
|
||||||
|
, drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
|
||||||
|
return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
|
||||||
|
, drCaption = SomeMessage MsgSheetDeleteQuestion
|
||||||
|
, drSuccessMessage = SomeMessage MsgSheetDeleted
|
||||||
|
, drAbort = error "drAbort undefined"
|
||||||
|
, drSuccess = error "drSuccess undefined"
|
||||||
|
}
|
||||||
|
|||||||
@ -9,25 +9,22 @@ import Utils.Lens
|
|||||||
|
|
||||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||||
addBonusToPoints sts =
|
addBonusToPoints sts =
|
||||||
sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts
|
sts & _normalSummary . _achievedPasses %~ (min passmax . (passbonus +))
|
||||||
& _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
|
& _normalSummary . _achievedPoints %~ (min ptsmax . (ptsbonus +))
|
||||||
where
|
where
|
||||||
bonusPoints = sts ^. _bonusSummary . _achievedPoints
|
passmax = sts ^. _normalSummary . _numMarkedPasses
|
||||||
maxPoints = sts ^. _normalSummary . _sumGradePoints
|
passbonus = sts ^. _bonusSummary . _achievedPasses
|
||||||
maxBonusPts = fmap $ min maxPoints
|
ptsmax = sts ^. _normalSummary . _sumMarkedPoints
|
||||||
addBonusPts = maybeAdd bonusPoints
|
ptsbonus = sts ^. _bonusSummary . _achievedPoints
|
||||||
|
|
||||||
bonusPasses = sts ^. _bonusSummary . _achievedPasses
|
gradeSummaryWidget :: RenderMessage UniWorX msg => (Integer -> msg) -> SheetTypeSummary -> Widget
|
||||||
maxPasses = sts ^. _normalSummary . _numGradePasses
|
|
||||||
maxBonusPass = fmap $ min maxPasses
|
|
||||||
addBonusPass = maybeAdd bonusPasses
|
|
||||||
|
|
||||||
gradeSummaryWidget :: RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
|
|
||||||
gradeSummaryWidget title sts =
|
gradeSummaryWidget title sts =
|
||||||
let SheetTypeSummary{..} = addBonusToPoints sts
|
let SheetTypeSummary{..} = addBonusToPoints sts
|
||||||
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
|
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
|
||||||
hasPassings = positiveSum $ numGradePasses sumSummaries
|
hasPasses = positiveSum $ numSheetsPasses sumSummaries
|
||||||
hasPoints = positiveSum $ sumGradePoints sumSummaries
|
hasMarkedPasses = positiveSum $ numMarkedPasses sumSummaries
|
||||||
|
hasPoints = positiveSum $ numSheetsPoints sumSummaries
|
||||||
|
hasMarkedPoints = positiveSum $ numMarkedPoints sumSummaries
|
||||||
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
|
||||||
| (sumHeader,summary) <-
|
| (sumHeader,summary) <-
|
||||||
[ (MsgSheetTypeNormal' ,normalSummary)
|
[ (MsgSheetTypeNormal' ,normalSummary)
|
||||||
|
|||||||
@ -5,12 +5,14 @@ module Handler.Utils.Submission
|
|||||||
, submissionFileSource, submissionFileQuery
|
, submissionFileSource, submissionFileQuery
|
||||||
, submissionMultiArchive
|
, submissionMultiArchive
|
||||||
, SubmissionSinkException(..)
|
, SubmissionSinkException(..)
|
||||||
|
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
|
||||||
, sinkSubmission, sinkMultiSubmission
|
, sinkSubmission, sinkMultiSubmission
|
||||||
, submissionMatchesSheet
|
, submissionMatchesSheet
|
||||||
|
, submissionDeleteRoute
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import hiding (joinPath)
|
import Import hiding (joinPath)
|
||||||
import Jobs
|
import Jobs.Queue
|
||||||
import Prelude (lcm)
|
import Prelude (lcm)
|
||||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||||
|
|
||||||
@ -36,11 +38,10 @@ import Data.Ratio
|
|||||||
import Data.Monoid (Monoid, Any(..), Sum(..))
|
import Data.Monoid (Monoid, Any(..), Sum(..))
|
||||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||||
|
|
||||||
import Handler.Utils.Rating hiding (extractRatings)
|
import Handler.Utils
|
||||||
import qualified Handler.Utils.Rating as Rating (extractRatings)
|
import qualified Handler.Utils.Rating as Rating (extractRatings)
|
||||||
import Handler.Utils.Zip
|
|
||||||
import Handler.Utils.Sheet
|
|
||||||
import Handler.Utils.Submission.TH
|
import Handler.Utils.Submission.TH
|
||||||
|
import Handler.Utils.Delete
|
||||||
|
|
||||||
import qualified Database.Esqueleto as E
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
@ -267,14 +268,6 @@ instance Monoid SubmissionSinkState where
|
|||||||
mempty = memptydefault
|
mempty = memptydefault
|
||||||
mappend = mappenddefault
|
mappend = mappenddefault
|
||||||
|
|
||||||
data SubmissionSinkException = DuplicateFileTitle FilePath
|
|
||||||
| DuplicateRating
|
|
||||||
| RatingWithoutUpdate
|
|
||||||
| ForeignRating CryptoFileNameSubmission
|
|
||||||
deriving (Typeable, Show)
|
|
||||||
|
|
||||||
instance Exception SubmissionSinkException
|
|
||||||
|
|
||||||
submissionBlacklist :: [Pattern]
|
submissionBlacklist :: [Pattern]
|
||||||
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
||||||
|
|
||||||
@ -311,6 +304,18 @@ extractRatingsMsg = do
|
|||||||
mr <- (toHtml . ) <$> getMessageRender
|
mr <- (toHtml . ) <$> getMessageRender
|
||||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||||
|
|
||||||
|
-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
|
||||||
|
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
|
||||||
|
msgSubmissionErrors = flip catches
|
||||||
|
[ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException)
|
||||||
|
, E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException)
|
||||||
|
, E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do
|
||||||
|
mr <- getMessageRender
|
||||||
|
addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx)
|
||||||
|
return Nothing
|
||||||
|
] . fmap Just
|
||||||
|
|
||||||
|
|
||||||
sinkSubmission :: UserId
|
sinkSubmission :: UserId
|
||||||
-> Either SheetId SubmissionId
|
-> Either SheetId SubmissionId
|
||||||
-> Bool -- ^ Is this a correction
|
-> Bool -- ^ Is this a correction
|
||||||
@ -510,15 +515,6 @@ sinkSubmission userId mExists isUpdate = do
|
|||||||
-> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
|
-> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
|
||||||
| otherwise -> return ()
|
| otherwise -> return ()
|
||||||
|
|
||||||
data SubmissionMultiSinkException
|
|
||||||
= SubmissionSinkException
|
|
||||||
{ _submissionSinkId :: CryptoFileNameSubmission
|
|
||||||
, _submissionSinkFedFile :: Maybe FilePath
|
|
||||||
, _submissionSinkException :: SubmissionSinkException
|
|
||||||
}
|
|
||||||
deriving (Typeable, Show)
|
|
||||||
|
|
||||||
instance Exception SubmissionMultiSinkException
|
|
||||||
|
|
||||||
sinkMultiSubmission :: UserId
|
sinkMultiSubmission :: UserId
|
||||||
-> Bool {-^ Are these corrections -}
|
-> Bool {-^ Are these corrections -}
|
||||||
@ -605,3 +601,40 @@ submissionMatchesSheet tid ssh csh shn cid = do
|
|||||||
Submission{..} <- get404 sid
|
Submission{..} <- get404 sid
|
||||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||||
return sid
|
return sid
|
||||||
|
|
||||||
|
|
||||||
|
submissionDeleteRoute :: Set SubmissionId -> DeleteRoute Submission
|
||||||
|
submissionDeleteRoute drRecords = DeleteRoute
|
||||||
|
{ drRecords
|
||||||
|
, drUnjoin = \(submission `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> submission
|
||||||
|
, drGetInfo = \(submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||||
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||||
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||||
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||||
|
let lastEdit = E.sub_select . E.from $ \submissionEdit -> do
|
||||||
|
E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||||
|
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
|
||||||
|
E.limit 1
|
||||||
|
return $ submissionEdit E.^. SubmissionEditTime
|
||||||
|
E.orderBy [E.desc lastEdit]
|
||||||
|
return (submission E.^. SubmissionId, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||||
|
, drRenderRecord = \(E.Value subId', E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> do
|
||||||
|
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
|
||||||
|
subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
|
||||||
|
return [whamlet|
|
||||||
|
$newline never
|
||||||
|
<ul .list--comma-separated .list--inline .list--iconless>
|
||||||
|
$forall (dName, sName) <- subNames
|
||||||
|
<li>^{nameWidget dName sName}
|
||||||
|
(_{ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}, #{shn'})
|
||||||
|
|]
|
||||||
|
, drRecordConfirmString = \(E.Value subId', E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> do
|
||||||
|
subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
|
||||||
|
subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
|
||||||
|
let subNames' = Text.intercalate ", " subNames
|
||||||
|
return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
|
||||||
|
, drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
|
||||||
|
, drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
|
||||||
|
, drAbort = error "drAbort undefined"
|
||||||
|
, drSuccess = error "drSuccess undefined"
|
||||||
|
}
|
||||||
|
|||||||
@ -1,15 +1,20 @@
|
|||||||
|
{-# OPTIONS -fno-warn-orphans #-}
|
||||||
|
|
||||||
module Handler.Utils.Table.Pagination
|
module Handler.Utils.Table.Pagination
|
||||||
( SortColumn(..), SortDirection(..)
|
( module Handler.Utils.Table.Pagination.Types
|
||||||
|
, SortColumn(..), SortDirection(..)
|
||||||
|
, pattern SortAscBy, pattern SortDescBy
|
||||||
, FilterColumn(..), IsFilterColumn
|
, FilterColumn(..), IsFilterColumn
|
||||||
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
|
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
|
||||||
, DBStyle(..), DBEmptyStyle(..)
|
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
|
||||||
, DBTable(..), IsDBTable(..), DBCell(..)
|
, DBTable(..), IsDBTable(..), DBCell(..)
|
||||||
|
, DBParams(..)
|
||||||
, cellAttrs, cellContents
|
, cellAttrs, cellContents
|
||||||
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
||||||
, PSValidator(..)
|
, PSValidator(..)
|
||||||
, defaultFilter, defaultSorting
|
, defaultFilter, defaultSorting
|
||||||
, restrictFilter, restrictSorting
|
, restrictFilter, restrictSorting
|
||||||
, ToSortable(..), Sortable(..), sortable
|
, ToSortable(..), Sortable(..)
|
||||||
, dbTable
|
, dbTable
|
||||||
, dbTableWidget, dbTableWidget'
|
, dbTableWidget, dbTableWidget'
|
||||||
, widgetColonnade, formColonnade, dbColonnade
|
, widgetColonnade, formColonnade, dbColonnade
|
||||||
@ -25,6 +30,7 @@ module Handler.Utils.Table.Pagination
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Handler.Utils.Table.Pagination.Types
|
import Handler.Utils.Table.Pagination.Types
|
||||||
|
import Handler.Utils.Form
|
||||||
import Utils
|
import Utils
|
||||||
import Utils.Lens.TH
|
import Utils.Lens.TH
|
||||||
|
|
||||||
@ -37,9 +43,6 @@ import qualified Data.Binary.Builder as Builder
|
|||||||
|
|
||||||
import qualified Network.Wai as Wai
|
import qualified Network.Wai as Wai
|
||||||
|
|
||||||
import Data.CaseInsensitive (CI)
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
|
||||||
|
|
||||||
import Control.Monad.RWS hiding ((<>), mapM_)
|
import Control.Monad.RWS hiding ((<>), mapM_)
|
||||||
import Control.Monad.Writer hiding ((<>), mapM_)
|
import Control.Monad.Writer hiding ((<>), mapM_)
|
||||||
import Control.Monad.Reader (ReaderT(..), mapReaderT)
|
import Control.Monad.Reader (ReaderT(..), mapReaderT)
|
||||||
@ -50,6 +53,10 @@ import Data.Foldable (Foldable(foldMap))
|
|||||||
import Data.Map (Map, (!))
|
import Data.Map (Map, (!))
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
import Colonnade hiding (bool, fromMaybe, singleton)
|
import Colonnade hiding (bool, fromMaybe, singleton)
|
||||||
import qualified Colonnade (singleton)
|
import qualified Colonnade (singleton)
|
||||||
import Colonnade.Encode
|
import Colonnade.Encode
|
||||||
@ -60,22 +67,30 @@ import Data.Ratio ((%))
|
|||||||
|
|
||||||
import Control.Lens
|
import Control.Lens
|
||||||
|
|
||||||
import Data.Aeson (Options(..), defaultOptions, decodeStrict')
|
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
|
||||||
import Data.Aeson.Text
|
import Data.Aeson.Text
|
||||||
import Data.Aeson.TH (deriveJSON)
|
import Data.Aeson.TH (deriveJSON)
|
||||||
|
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
|
import Data.Proxy (Proxy(..))
|
||||||
|
|
||||||
|
|
||||||
|
$(sqlInTuples [2..16])
|
||||||
|
|
||||||
|
|
||||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||||
|
|
||||||
data SortDirection = SortAsc | SortDesc
|
data SortDirection = SortAsc | SortDesc
|
||||||
deriving (Eq, Ord, Enum, Show, Read)
|
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||||
|
|
||||||
|
instance Universe SortDirection
|
||||||
|
instance Finite SortDirection
|
||||||
|
|
||||||
instance PathPiece SortDirection where
|
instance PathPiece SortDirection where
|
||||||
toPathPiece SortAsc = "asc"
|
toPathPiece SortAsc = "asc"
|
||||||
toPathPiece SortDesc = "desc"
|
toPathPiece SortDesc = "desc"
|
||||||
fromPathPiece (CI.mk -> t)
|
fromPathPiece = finiteFromPathPiece
|
||||||
| t == "asc" = Just SortAsc
|
|
||||||
| t == "desc" = Just SortDesc
|
|
||||||
| otherwise = Nothing
|
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveJSON defaultOptions
|
||||||
{ constructorTagModifier = camelToPathPiece' 1
|
{ constructorTagModifier = camelToPathPiece' 1
|
||||||
@ -86,6 +101,29 @@ sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
|
|||||||
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
||||||
|
|
||||||
|
|
||||||
|
data SortingSetting = SortingSetting
|
||||||
|
{ sortKey :: SortingKey
|
||||||
|
, sortDir :: SortDirection
|
||||||
|
} deriving (Eq, Ord, Show, Read)
|
||||||
|
|
||||||
|
deriveJSON defaultOptions
|
||||||
|
{ fieldLabelModifier = camelToPathPiece' 1
|
||||||
|
} ''SortingSetting
|
||||||
|
|
||||||
|
instance PathPiece SortingSetting where
|
||||||
|
toPathPiece SortingSetting{..} = toPathPiece sortKey <> "-" <> toPathPiece sortDir
|
||||||
|
fromPathPiece str = do
|
||||||
|
let sep = "-"
|
||||||
|
let (Text.dropEnd (Text.length sep) -> key, dir) = Text.breakOnEnd sep str
|
||||||
|
SortingSetting <$> fromPathPiece key <*> fromPathPiece dir
|
||||||
|
|
||||||
|
pattern SortAscBy :: SortingKey -> SortingSetting
|
||||||
|
pattern SortAscBy key = SortingSetting key SortAsc
|
||||||
|
|
||||||
|
pattern SortDescBy :: SortingKey -> SortingSetting
|
||||||
|
pattern SortDescBy key = SortingSetting key SortDesc
|
||||||
|
|
||||||
|
|
||||||
data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
|
data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
|
||||||
|
|
||||||
filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
|
||||||
@ -109,10 +147,58 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
|
|||||||
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
|
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is3) is2
|
||||||
| otherwise = go (acc, is3 . (i:)) is2
|
| otherwise = go (acc, is3 . (i:)) is2
|
||||||
|
|
||||||
|
|
||||||
|
data PagesizeLimit = PagesizeLimit !Int64 | PagesizeAll
|
||||||
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
|
|
||||||
|
instance Bounded PagesizeLimit where
|
||||||
|
minBound = PagesizeLimit minBound
|
||||||
|
maxBound = PagesizeAll
|
||||||
|
|
||||||
|
instance Enum PagesizeLimit where
|
||||||
|
toEnum i
|
||||||
|
| toInteger i >= fromIntegral (minBound :: Int64)
|
||||||
|
, toInteger i <= fromIntegral (maxBound :: Int64)
|
||||||
|
= PagesizeLimit $ fromIntegral i
|
||||||
|
| toInteger i > fromIntegral (maxBound :: Int64)
|
||||||
|
= PagesizeAll
|
||||||
|
| otherwise
|
||||||
|
= error "toEnum PagesizeLimit: out of bounds"
|
||||||
|
fromEnum (PagesizeLimit i)
|
||||||
|
| toInteger i >= fromIntegral (minBound :: Int)
|
||||||
|
, toInteger i <= fromIntegral (maxBound :: Int)
|
||||||
|
= fromIntegral i
|
||||||
|
| otherwise
|
||||||
|
= error "fromEnum PagesizeLimit: out of bounds"
|
||||||
|
fromEnum PagesizeAll
|
||||||
|
= error "fromEnum PagesizeLimit: infinite"
|
||||||
|
|
||||||
|
succ (PagesizeLimit i)
|
||||||
|
| i == maxBound = PagesizeAll
|
||||||
|
| otherwise = PagesizeLimit $ succ i
|
||||||
|
succ PagesizeAll = error "succ PagesizeLimit: out of bounds"
|
||||||
|
pred (PagesizeLimit i)
|
||||||
|
| i == minBound = error "pred PagesizeLimit: out of bounds"
|
||||||
|
| otherwise = PagesizeLimit $ pred i
|
||||||
|
pred PagesizeAll = PagesizeLimit maxBound
|
||||||
|
|
||||||
|
instance PathPiece PagesizeLimit where
|
||||||
|
toPathPiece PagesizeAll = "all"
|
||||||
|
toPathPiece (PagesizeLimit n) = toPathPiece n
|
||||||
|
fromPathPiece str
|
||||||
|
| CI.mk str == "all" = Just PagesizeAll
|
||||||
|
| otherwise = PagesizeLimit <$> fromPathPiece str
|
||||||
|
|
||||||
|
deriveJSON defaultOptions
|
||||||
|
{ constructorTagModifier = camelToPathPiece' 1
|
||||||
|
, sumEncoding = UntaggedValue
|
||||||
|
} ''PagesizeLimit
|
||||||
|
|
||||||
|
|
||||||
data PaginationSettings = PaginationSettings
|
data PaginationSettings = PaginationSettings
|
||||||
{ psSorting :: [(CI Text, SortDirection)]
|
{ psSorting :: [SortingSetting]
|
||||||
, psFilter :: Map (CI Text) [Text]
|
, psFilter :: Map FilterKey [Text]
|
||||||
, psLimit :: Int64
|
, psLimit :: PagesizeLimit
|
||||||
, psPage :: Int64
|
, psPage :: Int64
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -122,7 +208,7 @@ instance Default PaginationSettings where
|
|||||||
def = PaginationSettings
|
def = PaginationSettings
|
||||||
{ psSorting = []
|
{ psSorting = []
|
||||||
, psFilter = Map.empty
|
, psFilter = Map.empty
|
||||||
, psLimit = 50
|
, psLimit = PagesizeLimit 50
|
||||||
, psPage = 0
|
, psPage = 0
|
||||||
}
|
}
|
||||||
|
|
||||||
@ -131,9 +217,9 @@ deriveJSON defaultOptions
|
|||||||
} ''PaginationSettings
|
} ''PaginationSettings
|
||||||
|
|
||||||
data PaginationInput = PaginationInput
|
data PaginationInput = PaginationInput
|
||||||
{ piSorting :: Maybe [(CI Text, SortDirection)]
|
{ piSorting :: Maybe [SortingSetting]
|
||||||
, piFilter :: Maybe (Map (CI Text) [Text])
|
, piFilter :: Maybe (Map FilterKey [Text])
|
||||||
, piLimit :: Maybe Int64
|
, piLimit :: Maybe PagesizeLimit
|
||||||
, piPage :: Maybe Int64
|
, piPage :: Maybe Int64
|
||||||
} deriving (Eq, Ord, Show, Read, Generic)
|
} deriving (Eq, Ord, Show, Read, Generic)
|
||||||
|
|
||||||
@ -186,36 +272,38 @@ instance Default (PSValidator m x) where
|
|||||||
|
|
||||||
l <- asks piLimit
|
l <- asks piLimit
|
||||||
case l of
|
case l of
|
||||||
Just l'
|
Just (PagesizeLimit l')
|
||||||
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
| l' <= 0 -> tell . pure $ SomeMessage MsgPSLimitNonPositive
|
||||||
| otherwise -> modify $ \ps -> ps { psLimit = l' }
|
| otherwise -> modify $ \ps -> ps { psLimit = PagesizeLimit l' }
|
||||||
|
Just PagesizeAll
|
||||||
|
-> modify $ \ps -> ps { psLimit = PagesizeAll }
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
|
|
||||||
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
|
asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
|
||||||
|
|
||||||
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
|
defaultFilter :: Map FilterKey [Text] -> PSValidator m x -> PSValidator m x
|
||||||
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
|
defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
|
||||||
where
|
where
|
||||||
injectDefault x = case x >>= piFilter of
|
injectDefault x = case x >>= piFilter of
|
||||||
Just _ -> id
|
Just _ -> id
|
||||||
Nothing -> set (_2._psFilter) psFilter
|
Nothing -> set (_2._psFilter) psFilter
|
||||||
|
|
||||||
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
|
defaultSorting :: [SortingSetting] -> PSValidator m x -> PSValidator m x
|
||||||
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
|
defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable' -> injectDefault <*> f dbTable'
|
||||||
where
|
where
|
||||||
injectDefault x = case x >>= piSorting of
|
injectDefault x = case x >>= piSorting of
|
||||||
Just _ -> id
|
Just _ -> id
|
||||||
Nothing -> set (_2._psSorting) psSorting
|
Nothing -> set (_2._psSorting) psSorting
|
||||||
|
|
||||||
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
|
restrictFilter :: (FilterKey -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
|
||||||
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
|
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
|
||||||
where
|
where
|
||||||
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
|
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
|
||||||
|
|
||||||
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
|
restrictSorting :: (SortingKey -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
|
||||||
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
|
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable' ps -> over _2 restrict' $ f dbTable' ps
|
||||||
where
|
where
|
||||||
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
|
restrict' p = p { psSorting = filter (\SortingSetting{..} -> restrict sortKey sortDir) $ psSorting p }
|
||||||
|
|
||||||
|
|
||||||
data DBEmptyStyle = DBESNoHeading | DBESHeading
|
data DBEmptyStyle = DBESNoHeading | DBESHeading
|
||||||
@ -228,6 +316,11 @@ data DBStyle = DBStyle
|
|||||||
{ dbsEmptyStyle :: DBEmptyStyle
|
{ dbsEmptyStyle :: DBEmptyStyle
|
||||||
, dbsEmptyMessage :: UniWorXMessage
|
, dbsEmptyMessage :: UniWorXMessage
|
||||||
, dbsAttrs :: [(Text, Text)]
|
, dbsAttrs :: [(Text, Text)]
|
||||||
|
, dbsFilterLayout :: Widget -- ^ Filter UI
|
||||||
|
-> Enctype
|
||||||
|
-> Text -- ^ Filter action (target uri)
|
||||||
|
-> Widget -- ^ Table
|
||||||
|
-> Widget
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Default DBStyle where
|
instance Default DBStyle where
|
||||||
@ -235,24 +328,41 @@ instance Default DBStyle where
|
|||||||
{ dbsEmptyStyle = def
|
{ dbsEmptyStyle = def
|
||||||
, dbsEmptyMessage = MsgNoTableContent
|
, dbsEmptyMessage = MsgNoTableContent
|
||||||
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
|
, dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
|
||||||
|
, dbsFilterLayout = \_filterWgdt _filterEnctype _filterAction scrolltable ->
|
||||||
|
[whamlet|
|
||||||
|
$newline never
|
||||||
|
<!-- No Filter UI -->
|
||||||
|
^{scrolltable}
|
||||||
|
|]
|
||||||
}
|
}
|
||||||
|
|
||||||
data DBTable m x = forall a r r' h i t.
|
defaultDBSFilterLayout :: Widget -- ^ Filter UI
|
||||||
|
-> Enctype
|
||||||
|
-> Text -- ^ Filter action (target uri)
|
||||||
|
-> Widget -- ^ Table
|
||||||
|
-> Widget
|
||||||
|
defaultDBSFilterLayout filterWgdt filterEnctype filterAction scrolltable = $(widgetFile "table/layout-filter-default")
|
||||||
|
|
||||||
|
data DBTable m x = forall a r r' h i t k k'.
|
||||||
( ToSortable h, Functor h
|
( ToSortable h, Functor h
|
||||||
, E.SqlSelect a r
|
, E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
|
||||||
, PathPiece i, Eq i
|
, PathPiece i, Eq i
|
||||||
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
||||||
) => DBTable
|
) => DBTable
|
||||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||||
|
, dbtRowKey :: t -> k
|
||||||
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
|
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
|
||||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||||
, dbtSorting :: Map (CI Text) (SortColumn t)
|
, dbtSorting :: Map SortingKey (SortColumn t)
|
||||||
, dbtFilter :: Map (CI Text) (FilterColumn t)
|
, dbtFilter :: Map FilterKey (FilterColumn t)
|
||||||
|
, dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
|
||||||
, dbtStyle :: DBStyle
|
, dbtStyle :: DBStyle
|
||||||
|
, dbtParams :: DBParams m x
|
||||||
, dbtIdent :: i
|
, dbtIdent :: i
|
||||||
}
|
}
|
||||||
|
|
||||||
class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
|
class (MonadHandler m, 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 :: *
|
||||||
-- type DBResult' m x :: *
|
-- type DBResult' m x :: *
|
||||||
|
|
||||||
@ -261,10 +371,10 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
|
|||||||
|
|
||||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||||
-- | Format @DBTable@ when sort-circuiting
|
-- | Format @DBTable@ when sort-circuiting
|
||||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> DBResult m x -> m' Widget
|
dbWidget :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> DBResult m x -> m' Widget
|
||||||
-- | Format @DBTable@ when not short-circuiting
|
-- | Format @DBTable@ when not short-circuiting
|
||||||
dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
dbHandler :: forall m' p p'. (MonadHandler m', HandlerSite m' ~ UniWorX) => p m -> p' x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
|
||||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
runDBTable :: forall m' k'. (MonadHandler m', HandlerSite m' ~ UniWorX, ToJSON k') => DBTable m x -> PaginationInput -> [k'] -> m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
|
||||||
|
|
||||||
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
|
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
|
||||||
cellAttrs = dbCell . _1
|
cellAttrs = dbCell . _1
|
||||||
@ -273,6 +383,7 @@ cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
|
|||||||
cellContents = dbCell . _2
|
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 (HandlerT UniWorX IO) x = (x, Widget)
|
||||||
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
||||||
|
|
||||||
@ -288,13 +399,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
|
|||||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||||
dbWidget _ _ = return . snd
|
dbWidget _ _ = return . snd
|
||||||
dbHandler _ _ f = return . over _2 f
|
dbHandler _ _ f = return . over _2 f
|
||||||
runDBTable = liftHandlerT
|
runDBTable _ _ _ = liftHandlerT
|
||||||
|
|
||||||
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
|
||||||
mempty = WidgetCell mempty $ return mempty
|
mempty = WidgetCell mempty $ return mempty
|
||||||
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
|
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
|
||||||
|
|
||||||
|
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)
|
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
|
||||||
|
|
||||||
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
|
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
|
||||||
@ -309,15 +424,25 @@ instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x wher
|
|||||||
dbWidget _ _ = return . snd
|
dbWidget _ _ = return . snd
|
||||||
dbHandler _ _ f = return . over _2 f
|
dbHandler _ _ f = return . over _2 f
|
||||||
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
|
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
|
||||||
runDBTable = mapReaderT liftHandlerT
|
runDBTable _ _ _ = mapReaderT liftHandlerT
|
||||||
|
|
||||||
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||||
mempty = DBCell mempty $ return mempty
|
mempty = DBCell mempty $ return mempty
|
||||||
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
|
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
|
||||||
|
|
||||||
|
instance Default (DBParams (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
|
||||||
|
def = DBParamsDB
|
||||||
|
|
||||||
instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
|
instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
|
||||||
-- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
|
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
|
||||||
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
|
{ dbParamsFormMethod :: StdMethod
|
||||||
|
, dbParamsFormAction :: Maybe (SomeRoute UniWorX)
|
||||||
|
, dbParamsFormAttrs :: [(Text, Text)]
|
||||||
|
, dbParamsFormAddSubmit :: Bool
|
||||||
|
, dbParamsFormAdditional :: Form a
|
||||||
|
, dbParamsFormEvaluate :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX, MonadResource m') => Form a -> m' ((FormResult a, Widget), Enctype)
|
||||||
|
}
|
||||||
|
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Widget)
|
||||||
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
|
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
|
||||||
|
|
||||||
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
|
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
|
||||||
@ -334,21 +459,68 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
|||||||
|
|
||||||
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||||
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
|
dbWidget _ _ = return . snd
|
||||||
dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form
|
dbHandler _ _ f = return . over _2 f
|
||||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
||||||
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
|
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
|
||||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
|
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
|
||||||
runDBTable = return . withFragment
|
runDBTable dbtable pi pKeys = fmap (view _1) . dbParamsFormEvaluate (dbtParams dbtable) . dbParamsFormWrap (dbtParams dbtable) . addPIHiddenField dbtable pi . addPreviousHiddenField dbtable pKeys . withFragment
|
||||||
|
|
||||||
addPIHiddenField :: DBTable m x -> PaginationInput -> Form a -> Form a
|
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
||||||
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
|
def = DBParamsForm
|
||||||
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|
{ dbParamsFormMethod = POST
|
||||||
|
, dbParamsFormAction = Nothing
|
||||||
|
, dbParamsFormAttrs = []
|
||||||
|
, dbParamsFormAddSubmit = False
|
||||||
|
, dbParamsFormAdditional = \_ -> return mempty
|
||||||
|
, dbParamsFormEvaluate = liftHandlerT . runFormPost
|
||||||
|
}
|
||||||
|
|
||||||
|
dbParamsFormWrap :: Monoid a => DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) -> Form a -> Form a
|
||||||
|
dbParamsFormWrap DBParamsForm{..} tableForm frag = do
|
||||||
|
let form = mappend <$> tableForm frag <*> dbParamsFormAdditional mempty
|
||||||
|
((res, fWidget), enctype) <- listen form
|
||||||
|
return . (res,) $ do
|
||||||
|
btnId <- newIdent
|
||||||
|
act <- traverse toTextUrl dbParamsFormAction
|
||||||
|
let submitField :: Field Handler SubmitButton
|
||||||
|
submitField = buttonField BtnSubmit
|
||||||
|
submitView :: Widget
|
||||||
|
submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False
|
||||||
|
enctype' = bool id (mappend $ fieldEnctype submitField) dbParamsFormAddSubmit enctype
|
||||||
|
$(widgetFile "table/form-wrap")
|
||||||
|
|
||||||
|
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
||||||
|
|
||||||
|
instance PathPiece x => PathPiece (WithIdent x) where
|
||||||
|
toPathPiece (WithIdent ident x)
|
||||||
|
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
||||||
|
| otherwise = toPathPiece x
|
||||||
|
fromPathPiece txt = do
|
||||||
|
let sep = "-"
|
||||||
|
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
||||||
|
WithIdent <$> pure ident <*> fromPathPiece rest
|
||||||
|
|
||||||
|
addPIHiddenField :: DBTable m' x -> PaginationInput -> (Html -> MForm m a) -> (Html -> MForm m a)
|
||||||
|
addPIHiddenField DBTable{ dbtIdent } pi form fragment
|
||||||
|
= form $ fragment <> [shamlet|
|
||||||
|
$newline never
|
||||||
|
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
wIdent :: Text -> Text
|
||||||
|
wIdent = toPathPiece . WithIdent dbtIdent
|
||||||
|
|
||||||
|
addPreviousHiddenField :: (ToJSON k', MonadHandler m, HandlerSite m ~ UniWorX) => DBTable m' x -> [k'] -> (Html -> MForm m a) -> (Html -> MForm m a)
|
||||||
|
addPreviousHiddenField DBTable{ dbtIdent } pKeys form fragment = do
|
||||||
|
encrypted <- encodedSecretBox SecretBoxShort pKeys
|
||||||
|
form $ fragment <> [shamlet|
|
||||||
|
$newline never
|
||||||
|
<input type=hidden name=#{wIdent "previous"} value=#{encrypted}>
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
wIdent n
|
wIdent :: Text -> Text
|
||||||
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
wIdent = toPathPiece . WithIdent dbtIdent
|
||||||
| otherwise = n
|
|
||||||
|
|
||||||
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
|
||||||
mempty = FormCell mempty (return mempty)
|
mempty = FormCell mempty (return mempty)
|
||||||
@ -362,14 +534,13 @@ dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> DB (DB
|
|||||||
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. } = do
|
||||||
let
|
let
|
||||||
sortingOptions = mkOptionList
|
sortingOptions = mkOptionList
|
||||||
[ Option t' (t, d) t'
|
[ Option t' (SortingSetting t d) t'
|
||||||
| (t, _) <- mapToList dbtSorting
|
| (t, _) <- mapToList dbtSorting
|
||||||
, d <- [SortAsc, SortDesc]
|
, d <- [SortAsc, SortDesc]
|
||||||
, let t' = CI.foldedCase t <> "-" <> toPathPiece d
|
, let t' = toPathPiece $ SortingSetting t d
|
||||||
]
|
]
|
||||||
wIdent n
|
wIdent :: Text -> Text
|
||||||
| not $ null dbtIdent = dbtIdent <> "-" <> n
|
wIdent = toPathPiece . WithIdent dbtIdent
|
||||||
| otherwise = n
|
|
||||||
dbsAttrs'
|
dbsAttrs'
|
||||||
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
|
||||||
| otherwise = dbsAttrs
|
| otherwise = dbsAttrs
|
||||||
@ -379,62 +550,120 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
, fieldEnctype = UrlEncoded
|
, fieldEnctype = UrlEncoded
|
||||||
}
|
}
|
||||||
|
|
||||||
piResult <- lift . runInputGetResult $ PaginationInput
|
piPrevious <- lift . runInputMaybe $ ireq (jsonField True) (wIdent "pagination")
|
||||||
|
let piPreviousRes = maybe FormMissing FormSuccess piPrevious
|
||||||
|
previousKeys <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ wIdent "previous")
|
||||||
|
|
||||||
|
piInput <- lift . runInputGetResult $ PaginationInput
|
||||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter)
|
||||||
<*> iopt intField (wIdent "pagesize")
|
<*> iopt pathPieceField (wIdent "pagesize")
|
||||||
<*> iopt intField (wIdent "page")
|
<*> iopt intField (wIdent "page")
|
||||||
|
|
||||||
piPrevious <- fmap (maybe FormMissing FormSuccess) . runMaybeT $ MaybeT . return . decodeStrict' . encodeUtf8 =<< MaybeT (lookupPostParam $ wIdent "pagination")
|
let prevPi
|
||||||
|
| FormSuccess pi <- piPreviousRes <|> piInput
|
||||||
|
= pi
|
||||||
|
| otherwise
|
||||||
|
= def
|
||||||
|
|
||||||
|
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
|
||||||
|
(filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
|
||||||
|
|
||||||
|
let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
|
||||||
|
|
||||||
|
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
|
||||||
|
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
|
||||||
|
<* autosubmitButton
|
||||||
|
return (filterRes', pagesizeRes')
|
||||||
|
|
||||||
|
let
|
||||||
|
piResult = (\fSettings -> prevPi & _piFilter .~ Just fSettings) <$> filterRes
|
||||||
|
<|> (\ps -> prevPi & _piLimit .~ Just ps) <$> pagesizeRes
|
||||||
|
<|> piPreviousRes
|
||||||
|
<|> piInput
|
||||||
|
|
||||||
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
psShortcircuit <- (== Just dbtIdent') <$> lookupCustomHeader HeaderDBTableShortcircuit
|
||||||
|
|
||||||
let
|
let
|
||||||
(errs, PaginationSettings{..}) = case piPrevious <|> piResult of
|
(errs, PaginationSettings{..}) = case piResult of
|
||||||
FormSuccess pi
|
FormSuccess pi
|
||||||
| not (piIsUnset pi)
|
| not (piIsUnset pi)
|
||||||
-> runPSValidator dbtable $ Just pi
|
-> runPSValidator dbtable $ Just pi
|
||||||
FormFailure errs'
|
FormFailure errs'
|
||||||
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
|
||||||
_ -> runPSValidator dbtable Nothing
|
_ -> runPSValidator dbtable Nothing
|
||||||
paginationInput
|
paginationInput@PaginationInput{..}
|
||||||
| FormSuccess pi <- piPrevious <|> piResult
|
| FormSuccess pi <- piResult
|
||||||
, not $ piIsUnset pi
|
, not $ piIsUnset pi
|
||||||
= pi
|
= pi
|
||||||
| otherwise
|
| otherwise
|
||||||
= def
|
= def
|
||||||
psSorting' = map (first (dbtSorting !)) psSorting
|
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
|
||||||
|
|
||||||
mapM_ (addMessageI Warning) errs
|
mapM_ (addMessageI Warning) errs
|
||||||
|
|
||||||
rows' <- E.select . E.from $ \t -> do
|
rows' <- E.select . E.from $ \t -> do
|
||||||
res <- dbtSQLQuery t
|
res <- dbtSQLQuery t
|
||||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||||
E.limit psLimit
|
case previousKeys of
|
||||||
E.offset (psPage * psLimit)
|
Nothing
|
||||||
|
| PagesizeLimit l <- psLimit
|
||||||
|
-> do
|
||||||
|
E.limit l
|
||||||
|
E.offset (psPage * l)
|
||||||
|
Just ps -> E.where_ $ dbtRowKey t `sqlIn` ps
|
||||||
|
_other -> return ()
|
||||||
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
|
||||||
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), res)
|
return (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64), dbtRowKey t, res)
|
||||||
|
|
||||||
let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
|
let mapMaybeM f = fmap catMaybes . mapM (\(k, v) -> runMaybeT $ (,) <$> pure k <*> f v)
|
||||||
|
firstRow :: Int64
|
||||||
|
firstRow
|
||||||
|
| PagesizeLimit l <- psLimit
|
||||||
|
= succ (psPage * l)
|
||||||
|
| otherwise
|
||||||
|
= 1
|
||||||
|
|
||||||
rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
|
(currentKeys, rows) <- fmap unzip . mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrKey, dbrOutput)) -> (dbrKey, DBRow{..})) $ zip [firstRow..] rows'
|
||||||
|
|
||||||
|
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||||
|
let
|
||||||
|
tblLink :: (QueryText -> QueryText) -> Text
|
||||||
|
tblLink f = decodeUtf8 . toStrict . Builder.toLazyByteString . renderQueryText True $ (f . substPi . setParam "_hasdata" Nothing) getParams
|
||||||
|
substPi = foldr (.) id
|
||||||
|
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
|
||||||
|
, foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
||||||
|
, setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
|
||||||
|
, setParam (wIdent "page") $ fmap toPathPiece piPage
|
||||||
|
, setParam (wIdent "pagination") Nothing
|
||||||
|
]
|
||||||
|
|
||||||
|
if
|
||||||
|
| Just pKeys <- previousKeys
|
||||||
|
, pKeys /= currentKeys
|
||||||
|
-> redirectWith preconditionFailed412 $ tblLink id
|
||||||
|
| otherwise
|
||||||
|
-> return ()
|
||||||
|
|
||||||
let
|
let
|
||||||
rowCount
|
rowCount
|
||||||
| (E.Value n, _):_ <- rows' = n
|
| (E.Value n, _, _):_ <- rows' = n
|
||||||
| otherwise = 0
|
| otherwise = 0
|
||||||
|
|
||||||
|
rawAction = tblLink
|
||||||
|
$ setParam (wIdent "sorting") Nothing
|
||||||
|
. setParam (wIdent "pagesize") Nothing
|
||||||
|
. setParam (wIdent "page") Nothing
|
||||||
|
. setParam (wIdent "pagination") Nothing
|
||||||
|
|
||||||
table' :: WriterT x m Widget
|
table' :: WriterT x m Widget
|
||||||
table' = do
|
table' = do
|
||||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
|
||||||
|
|
||||||
let
|
let
|
||||||
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
|
||||||
|
|
||||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||||
widget <- sortableContent ^. cellContents
|
widget <- sortableContent ^. cellContents
|
||||||
let
|
let
|
||||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
|
||||||
isSortable = isJust sortableKey
|
isSortable = isJust sortableKey
|
||||||
isSorted = (`elem` directions)
|
isSorted = (`elem` directions)
|
||||||
attrs = sortableContent ^. cellAttrs
|
attrs = sortableContent ^. cellAttrs
|
||||||
@ -451,20 +680,27 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
|||||||
return $(widgetFile "table/cell/body")
|
return $(widgetFile "table/cell/body")
|
||||||
|
|
||||||
let table = $(widgetFile "table/colonnade")
|
let table = $(widgetFile "table/colonnade")
|
||||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
pageCount
|
||||||
|
| PagesizeLimit l <- psLimit
|
||||||
|
= max 1 . ceiling $ rowCount % l
|
||||||
|
| otherwise
|
||||||
|
= 1
|
||||||
pageNumbers = [0..pred pageCount]
|
pageNumbers = [0..pred pageCount]
|
||||||
|
|
||||||
return $(widgetFile "table/layout")
|
return $(widgetFile "table/layout")
|
||||||
|
|
||||||
bool (dbHandler dbtable paginationInput $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable paginationInput) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . dbsFilterLayout filterWdgt filterEnc rawAction) (sendResponse <=< tblLayout . dbsFilterLayout filterWdgt filterEnc rawAction <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table'
|
||||||
where
|
where
|
||||||
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
|
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
|
||||||
tblLayout tbl' = do
|
tblLayout tbl' = do
|
||||||
tbl <- liftHandlerT $ widgetToPageContent tbl'
|
tbl <- liftHandlerT $ widgetToPageContent tbl'
|
||||||
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
|
withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
|
||||||
|
|
||||||
|
setParams :: Text -> [Text] -> QueryText -> QueryText
|
||||||
|
setParams key vs qt = map ((key, ) . Just) vs ++ [ i | i@(key', _) <- qt, key' /= key ]
|
||||||
|
|
||||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||||
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
|
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)
|
-> DB (DBResult (HandlerT UniWorX IO) x)
|
||||||
@ -488,6 +724,23 @@ 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
|
dbColonnade = id
|
||||||
|
|
||||||
|
pagesizeField :: PagesizeLimit -> Field Handler PagesizeLimit
|
||||||
|
pagesizeField psLim = selectField $ do
|
||||||
|
MsgRenderer mr <- getMsgRenderer
|
||||||
|
let
|
||||||
|
optText (PagesizeLimit l) = tshow l
|
||||||
|
optText PagesizeAll = mr MsgDBTablePagesizeAll
|
||||||
|
|
||||||
|
toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList
|
||||||
|
return $ toOptionList limOpts
|
||||||
|
where
|
||||||
|
limOpts :: [PagesizeLimit]
|
||||||
|
limOpts = psLim : PagesizeAll : map PagesizeLimit opts
|
||||||
|
|
||||||
|
opts :: [Int64]
|
||||||
|
opts = filter (> 0) $ opts' <> map (`div` 2) opts'
|
||||||
|
|
||||||
|
opts' = [ 10^n | n <- [1..3]]
|
||||||
|
|
||||||
--- DBCell utility functions
|
--- DBCell utility functions
|
||||||
|
|
||||||
@ -556,16 +809,17 @@ instance Ord i => Monoid (DBFormResult r i a) where
|
|||||||
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
|
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
|
||||||
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
||||||
|
|
||||||
formCell :: forall r i a. Ord i
|
formCell :: forall res r i a. (Ord i, Monoid res)
|
||||||
=> (r -> MForm (HandlerT UniWorX IO) i)
|
=> Lens' res (DBFormResult r i a)
|
||||||
|
-> (r -> MForm (HandlerT UniWorX IO) i)
|
||||||
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
|
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
|
||||||
-> (r -> DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
|
-> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
|
||||||
formCell genIndex genForm input = FormCell
|
formCell resLens genIndex genForm input = FormCell
|
||||||
{ formCellAttrs = []
|
{ formCellAttrs = []
|
||||||
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
||||||
i <- genIndex input
|
i <- genIndex input
|
||||||
(edit, w) <- genForm input i
|
(edit, w) <- genForm input i
|
||||||
return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
|
return (flip (set resLens) mempty . DBFormResult . Map.singleton i . (input,) <$> edit, w)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
@ -575,10 +829,11 @@ formCell genIndex genForm input = FormCell
|
|||||||
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
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
|
dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||||
|
|
||||||
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
|
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
|
||||||
=> Setter' a Bool
|
=> Lens' res (DBFormResult r i a)
|
||||||
|
-> Setter' a Bool
|
||||||
-> (r -> MForm (HandlerT UniWorX IO) i)
|
-> (r -> MForm (HandlerT UniWorX IO) i)
|
||||||
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult r i a)))
|
-> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
|
||||||
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
|
dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell resLens genIndex) r $ \_ i -> do
|
||||||
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
|
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
|
||||||
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
||||||
|
|||||||
@ -1,4 +1,14 @@
|
|||||||
module Handler.Utils.Table.Pagination.Types where
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
|
|
||||||
|
module Handler.Utils.Table.Pagination.Types
|
||||||
|
( FilterKey, SortingKey
|
||||||
|
, Sortable(..)
|
||||||
|
, sortable
|
||||||
|
, ToSortable(..)
|
||||||
|
, SortableP(..)
|
||||||
|
, SqlIn(..)
|
||||||
|
, sqlInTuples
|
||||||
|
) where
|
||||||
|
|
||||||
import Import hiding (singleton)
|
import Import hiding (singleton)
|
||||||
|
|
||||||
@ -7,12 +17,30 @@ import Colonnade.Encode
|
|||||||
|
|
||||||
import Data.CaseInsensitive (CI)
|
import Data.CaseInsensitive (CI)
|
||||||
|
|
||||||
|
import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
|
||||||
|
|
||||||
|
import Language.Haskell.TH
|
||||||
|
|
||||||
|
import Data.List (foldr1, foldl)
|
||||||
|
|
||||||
|
|
||||||
|
newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
|
||||||
|
deriving (Show, Read)
|
||||||
|
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
|
||||||
|
newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
|
||||||
|
deriving (Show, Read)
|
||||||
|
deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
|
||||||
|
|
||||||
|
|
||||||
data Sortable a = Sortable
|
data Sortable a = Sortable
|
||||||
{ sortableKey :: Maybe (CI Text)
|
{ sortableKey :: Maybe SortingKey
|
||||||
, sortableContent :: a
|
, sortableContent :: a
|
||||||
}
|
}
|
||||||
|
|
||||||
sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c
|
sortable :: Maybe SortingKey -> c -> (a -> c) -> Colonnade Sortable a c
|
||||||
sortable k h = singleton (Sortable k h)
|
sortable k h = singleton (Sortable k h)
|
||||||
|
|
||||||
instance Headedness Sortable where
|
instance Headedness Sortable where
|
||||||
@ -36,3 +64,35 @@ instance ToSortable Headed where
|
|||||||
|
|
||||||
instance ToSortable Headless where
|
instance ToSortable Headless where
|
||||||
pSortable = Nothing
|
pSortable = Nothing
|
||||||
|
|
||||||
|
|
||||||
|
class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
|
||||||
|
sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
|
||||||
|
|
||||||
|
instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
|
||||||
|
x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)
|
||||||
|
|
||||||
|
sqlInTuples :: [Int] -> DecsQ
|
||||||
|
sqlInTuples = mapM sqlInTuple
|
||||||
|
|
||||||
|
sqlInTuple :: Int -> DecQ
|
||||||
|
sqlInTuple arity = do
|
||||||
|
tyVars <- replicateM arity $ newName "t"
|
||||||
|
vVs <- replicateM arity $ newName "v"
|
||||||
|
xVs <- replicateM arity $ newName "x"
|
||||||
|
xsV <- newName "xs"
|
||||||
|
|
||||||
|
let
|
||||||
|
matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
|
||||||
|
tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars
|
||||||
|
|
||||||
|
instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
|
||||||
|
[ funD 'sqlIn
|
||||||
|
[ clause [tupP $ map varP xVs, varP xsV]
|
||||||
|
( guardedB
|
||||||
|
[ normalGE [e|null $(varE xsV)|] [e|E.val False|]
|
||||||
|
, normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
|
||||||
|
]
|
||||||
|
) []
|
||||||
|
]
|
||||||
|
]
|
||||||
|
|||||||
@ -8,6 +8,7 @@ import Model as Import
|
|||||||
import Model.Types.JSON as Import
|
import Model.Types.JSON as Import
|
||||||
import Model.Migration as Import
|
import Model.Migration as Import
|
||||||
import Model.Rating as Import
|
import Model.Rating as Import
|
||||||
|
import Model.Submission as Import
|
||||||
import Settings as Import
|
import Settings as Import
|
||||||
import Settings.StaticFiles as Import
|
import Settings.StaticFiles as Import
|
||||||
import Yesod.Auth as Import
|
import Yesod.Auth as Import
|
||||||
@ -15,6 +16,7 @@ import Yesod.Core.Types as Import (loggerSet)
|
|||||||
import Yesod.Default.Config2 as Import
|
import Yesod.Default.Config2 as Import
|
||||||
import Utils as Import
|
import Utils as Import
|
||||||
import Yesod.Core.Json as Import (provideJson)
|
import Yesod.Core.Json as Import (provideJson)
|
||||||
|
import Yesod.Core.Types.Instances as Import ()
|
||||||
|
|
||||||
|
|
||||||
import Data.Fixed as Import
|
import Data.Fixed as Import
|
||||||
@ -41,6 +43,8 @@ import Data.Hashable as Import
|
|||||||
import Data.List.NonEmpty as Import (NonEmpty(..))
|
import Data.List.NonEmpty as Import (NonEmpty(..))
|
||||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||||
import Data.Semigroup as Import (Semigroup)
|
import Data.Semigroup as Import (Semigroup)
|
||||||
|
import Data.Monoid as Import (Last(..), First(..))
|
||||||
|
import Data.Monoid.Instances as Import ()
|
||||||
|
|
||||||
import Control.Monad.Morph as Import (MFunctor(..))
|
import Control.Monad.Morph as Import (MFunctor(..))
|
||||||
|
|
||||||
@ -49,6 +53,8 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
|||||||
import Network.Mail.Mime.Instances as Import ()
|
import Network.Mail.Mime.Instances as Import ()
|
||||||
import Yesod.Core.Instances as Import ()
|
import Yesod.Core.Instances as Import ()
|
||||||
|
|
||||||
|
import Ldap.Client.Pool as Import
|
||||||
|
|
||||||
|
|
||||||
import Control.Monad.Trans.RWS (RWST)
|
import Control.Monad.Trans.RWS (RWST)
|
||||||
|
|
||||||
|
|||||||
@ -57,6 +57,7 @@ import Jobs.Handler.SendTestEmail
|
|||||||
import Jobs.Handler.QueueNotification
|
import Jobs.Handler.QueueNotification
|
||||||
import Jobs.Handler.HelpRequest
|
import Jobs.Handler.HelpRequest
|
||||||
import Jobs.Handler.SetLogSettings
|
import Jobs.Handler.SetLogSettings
|
||||||
|
import Jobs.Handler.DistributeCorrections
|
||||||
|
|
||||||
|
|
||||||
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
data JobQueueException = JInvalid QueuedJobId QueuedJob
|
||||||
|
|||||||
@ -71,6 +71,15 @@ determineCrontab = execWriterT $ do
|
|||||||
, cronRateLimit = appNotificationRateLimit
|
, cronRateLimit = appNotificationRateLimit
|
||||||
, cronNotAfter = Left appNotificationExpiration
|
, cronNotAfter = Left appNotificationExpiration
|
||||||
}
|
}
|
||||||
|
when sheetAutoDistribute $
|
||||||
|
tell $ HashMap.singleton
|
||||||
|
(JobCtlQueue $ JobDistributeCorrections nSheet)
|
||||||
|
Cron
|
||||||
|
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
|
||||||
|
, cronRepeat = CronRepeatNever
|
||||||
|
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
|
||||||
|
, cronNotAfter = Left nominalDay
|
||||||
|
}
|
||||||
|
|
||||||
sheetSubmissions <- lift $ collateSubmissions <$>
|
sheetSubmissions <- lift $ collateSubmissions <$>
|
||||||
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []
|
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []
|
||||||
|
|||||||
21
src/Jobs/Handler/DistributeCorrections.hs
Normal file
21
src/Jobs/Handler/DistributeCorrections.hs
Normal file
@ -0,0 +1,21 @@
|
|||||||
|
module Jobs.Handler.DistributeCorrections
|
||||||
|
( dispatchJobDistributeCorrections
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import Jobs.Queue
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Reader (mapReaderT)
|
||||||
|
|
||||||
|
import Handler.Utils.Submission
|
||||||
|
|
||||||
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
|
||||||
|
dispatchJobDistributeCorrections :: SheetId
|
||||||
|
-> Handler ()
|
||||||
|
dispatchJobDistributeCorrections jSheet = runDBJobs $ do
|
||||||
|
(_, unassigned) <- mapReaderT lift $ assignSubmissions jSheet Nothing
|
||||||
|
unless (Set.null unassigned) $
|
||||||
|
queueDBJob . JobQueueNotification $ NotificationCorrectionsNotDistributed jSheet
|
||||||
@ -22,26 +22,37 @@ dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
|
|||||||
|
|
||||||
|
|
||||||
determineNotificationCandidates :: Notification -> DB [Entity User]
|
determineNotificationCandidates :: Notification -> DB [Entity User]
|
||||||
determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
determineNotificationCandidates NotificationSubmissionRated{..}
|
||||||
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
= E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
|
||||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
|
||||||
return user
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
|
||||||
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
return user
|
||||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
determineNotificationCandidates NotificationSheetActive{..}
|
||||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||||
return user
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||||
determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||||
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
return user
|
||||||
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
determineNotificationCandidates NotificationSheetSoonInactive{..}
|
||||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
|
||||||
return user
|
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
|
||||||
determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
|
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||||
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||||
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
return user
|
||||||
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
determineNotificationCandidates NotificationSheetInactive{..}
|
||||||
return user
|
= E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
|
||||||
determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] []
|
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
|
||||||
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||||
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||||
|
return user
|
||||||
|
determineNotificationCandidates NotificationCorrectionsAssigned{..}
|
||||||
|
= selectList [UserId ==. nUser] []
|
||||||
|
determineNotificationCandidates NotificationCorrectionsNotDistributed{nSheet}
|
||||||
|
= E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
|
||||||
|
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
|
||||||
|
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
|
||||||
|
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
|
||||||
|
return user
|
||||||
|
|
||||||
classifyNotification :: Notification -> DB NotificationTrigger
|
classifyNotification :: Notification -> DB NotificationTrigger
|
||||||
classifyNotification NotificationSubmissionRated{..} = do
|
classifyNotification NotificationSubmissionRated{..} = do
|
||||||
@ -53,5 +64,6 @@ classifyNotification NotificationSheetActive{} = return NTSheetActive
|
|||||||
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
|
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
|
||||||
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
|
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
|
||||||
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
|
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
|
||||||
|
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -11,6 +11,7 @@ import Jobs.Handler.SendNotification.SubmissionRated
|
|||||||
import Jobs.Handler.SendNotification.SheetActive
|
import Jobs.Handler.SendNotification.SheetActive
|
||||||
import Jobs.Handler.SendNotification.SheetInactive
|
import Jobs.Handler.SendNotification.SheetInactive
|
||||||
import Jobs.Handler.SendNotification.CorrectionsAssigned
|
import Jobs.Handler.SendNotification.CorrectionsAssigned
|
||||||
|
import Jobs.Handler.SendNotification.CorrectionsNotDistributed
|
||||||
|
|
||||||
|
|
||||||
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
|
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
|
||||||
|
|||||||
@ -22,7 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
|
|||||||
]
|
]
|
||||||
return (course, sheet, nbrSubs)
|
return (course, sheet, nbrSubs)
|
||||||
when (nbrSubs > 0) . userMailT jRecipient $ do
|
when (nbrSubs > 0) . userMailT jRecipient $ do
|
||||||
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
|
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
|
||||||
|
|
||||||
MsgRenderer mr <- getMailMsgRenderer
|
MsgRenderer mr <- getMailMsgRenderer
|
||||||
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||||
|
|||||||
@ -0,0 +1,31 @@
|
|||||||
|
module Jobs.Handler.SendNotification.CorrectionsNotDistributed
|
||||||
|
( dispatchNotificationCorrectionsNotDistributed
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
import Handler.Utils.Mail
|
||||||
|
|
||||||
|
import Text.Hamlet
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
|
||||||
|
dispatchNotificationCorrectionsNotDistributed :: SheetId -> UserId -> Handler ()
|
||||||
|
dispatchNotificationCorrectionsNotDistributed nSheet jRecipient = do
|
||||||
|
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
|
||||||
|
sheet <- getJust nSheet
|
||||||
|
course <- belongsToJust sheetCourse sheet
|
||||||
|
nbrSubs <- count [ SubmissionSheet ==. nSheet
|
||||||
|
, SubmissionRatingBy ==. Nothing
|
||||||
|
]
|
||||||
|
return (course, sheet, nbrSubs)
|
||||||
|
when (nbrSubs > 0) . userMailT jRecipient $ do
|
||||||
|
setSubjectI $ MsgMailSubjectSubmissionsUnassigned courseShorthand sheetName
|
||||||
|
MsgRenderer mr <- getMailMsgRenderer
|
||||||
|
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
|
||||||
|
tid = courseTerm
|
||||||
|
ssh = courseSchool
|
||||||
|
csh = courseShorthand
|
||||||
|
shn = sheetName
|
||||||
|
|
||||||
|
addAlternatives $
|
||||||
|
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsUndistributed.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||||
@ -3,6 +3,7 @@ module Jobs.Queue
|
|||||||
, queueJob, queueJob'
|
, queueJob, queueJob'
|
||||||
, YesodJobDB
|
, YesodJobDB
|
||||||
, runDBJobs, queueDBJob
|
, runDBJobs, queueDBJob
|
||||||
|
, module Jobs.Types
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
|||||||
@ -19,12 +19,14 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
|
|||||||
, jRequestTime :: UTCTime
|
, jRequestTime :: UTCTime
|
||||||
, jHelpRequest :: Text, jReferer :: Maybe Text }
|
, jHelpRequest :: Text, jReferer :: Maybe Text }
|
||||||
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
|
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
|
||||||
|
| JobDistributeCorrections { jSheet :: SheetId }
|
||||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||||
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
|
||||||
| NotificationSheetActive { nSheet :: SheetId }
|
| NotificationSheetActive { nSheet :: SheetId }
|
||||||
| NotificationSheetSoonInactive { nSheet :: SheetId }
|
| NotificationSheetSoonInactive { nSheet :: SheetId }
|
||||||
| NotificationSheetInactive { nSheet :: SheetId }
|
| NotificationSheetInactive { nSheet :: SheetId }
|
||||||
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
|
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
|
||||||
|
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
|
||||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||||
|
|
||||||
instance Hashable Job
|
instance Hashable Job
|
||||||
|
|||||||
100
src/Ldap/Client/Pool.hs
Normal file
100
src/Ldap/Client/Pool.hs
Normal file
@ -0,0 +1,100 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
|
module Ldap.Client.Pool
|
||||||
|
( LdapPool
|
||||||
|
, LdapExecutor, Ldap, LdapError
|
||||||
|
, withLdap
|
||||||
|
, createLdapPool
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
|
||||||
|
import Ldap.Client (Ldap, LdapError)
|
||||||
|
import qualified Ldap.Client as Ldap
|
||||||
|
|
||||||
|
import Data.Pool
|
||||||
|
|
||||||
|
import Control.Monad.Logger
|
||||||
|
import Data.Time.Clock (NominalDiffTime)
|
||||||
|
|
||||||
|
import Data.Dynamic
|
||||||
|
|
||||||
|
|
||||||
|
type LdapPool = Pool LdapExecutor
|
||||||
|
data LdapExecutor = LdapExecutor
|
||||||
|
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
|
||||||
|
, ldapDestroy :: TMVar ()
|
||||||
|
}
|
||||||
|
|
||||||
|
instance Exception LdapError
|
||||||
|
|
||||||
|
|
||||||
|
withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap -> IO a) -> m (Either LdapError a)
|
||||||
|
withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
|
||||||
|
|
||||||
|
|
||||||
|
createLdapPool :: ( MonadLoggerIO m, MonadIO m )
|
||||||
|
=> Ldap.Host
|
||||||
|
-> Ldap.PortNumber
|
||||||
|
-> Int -- ^ Stripes
|
||||||
|
-> NominalDiffTime -- ^ Timeout
|
||||||
|
-> Int -- ^ Limit
|
||||||
|
-> m LdapPool
|
||||||
|
createLdapPool host port stripes timeout limit = do
|
||||||
|
logFunc <- askLoggerIO
|
||||||
|
|
||||||
|
let
|
||||||
|
mkExecutor :: IO LdapExecutor
|
||||||
|
mkExecutor = do
|
||||||
|
ldapDestroy <- newEmptyTMVarIO
|
||||||
|
ldapAct <- newEmptyTMVarIO
|
||||||
|
|
||||||
|
let
|
||||||
|
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapError a)
|
||||||
|
ldapExec act = do
|
||||||
|
ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
|
||||||
|
atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
|
||||||
|
either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
|
||||||
|
`catches`
|
||||||
|
[ Handler $ return . Left . Ldap.ParseError
|
||||||
|
, Handler $ return . Left . Ldap.ResponseError
|
||||||
|
, Handler $ return . Left . Ldap.IOError
|
||||||
|
, Handler $ return . Left . Ldap.DisconnectError
|
||||||
|
]
|
||||||
|
|
||||||
|
go :: Maybe (TMVar (Maybe a)) -> Ldap -> LoggingT IO ()
|
||||||
|
go waiting ldap = do
|
||||||
|
$logDebugS "LdapExecutor" "Waiting"
|
||||||
|
for_ waiting $ atomically . flip putTMVar Nothing
|
||||||
|
instruction <- atomically $ (Nothing <$ takeTMVar ldapDestroy) <|> (Just <$> takeTMVar ldapAct)
|
||||||
|
case instruction of
|
||||||
|
Nothing -> $logDebugS "LdapExecutor" "Terminating"
|
||||||
|
Just (act, returnRes) -> do
|
||||||
|
$logDebugS "LdapExecutor" "Executing"
|
||||||
|
res <- try . liftIO $ act ldap
|
||||||
|
didReturn <- atomically $ tryPutTMVar returnRes res
|
||||||
|
unless didReturn $
|
||||||
|
$logErrorS "LdapExecutor" "Could not return result"
|
||||||
|
either throwM (const $ return ()) res
|
||||||
|
`catches`
|
||||||
|
[ Handler (\(Ldap.ResponseError _) -> return ())
|
||||||
|
]
|
||||||
|
go Nothing ldap
|
||||||
|
|
||||||
|
setup <- newEmptyTMVarIO
|
||||||
|
void . fork . flip runLoggingT logFunc $ do
|
||||||
|
$logDebugS "LdapExecutor" "Starting"
|
||||||
|
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
|
||||||
|
case res of
|
||||||
|
Left exc -> do
|
||||||
|
$logWarnS "LdapExecutor" $ tshow exc
|
||||||
|
atomically . void . tryPutTMVar setup $ Just exc
|
||||||
|
Right res' -> return res'
|
||||||
|
|
||||||
|
maybe (return ()) throwM =<< atomically (takeTMVar setup)
|
||||||
|
|
||||||
|
return LdapExecutor{..}
|
||||||
|
|
||||||
|
delExecutor :: LdapExecutor -> IO ()
|
||||||
|
delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
|
||||||
|
liftIO $ createPool mkExecutor delExecutor stripes timeout limit
|
||||||
@ -8,9 +8,10 @@ module Model
|
|||||||
|
|
||||||
import ClassyPrelude.Yesod
|
import ClassyPrelude.Yesod
|
||||||
import Database.Persist.Quasi
|
import Database.Persist.Quasi
|
||||||
|
import Database.Persist.TH.Directory
|
||||||
-- import Data.Time
|
-- import Data.Time
|
||||||
-- import Data.ByteString
|
-- import Data.ByteString
|
||||||
import Model.Types
|
import Model.Types hiding (_maxPoints, _passingPoints)
|
||||||
import Cron.Types
|
import Cron.Types
|
||||||
|
|
||||||
import Data.Aeson (Value)
|
import Data.Aeson (Value)
|
||||||
@ -26,7 +27,7 @@ import Settings.Cluster (ClusterSettingsKey)
|
|||||||
-- at:
|
-- at:
|
||||||
-- http://www.yesodweb.com/book/persistent/
|
-- http://www.yesodweb.com/book/persistent/
|
||||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
|
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
|
||||||
$(persistFileWith lowerCaseSettings "models")
|
$(persistDirectoryWith lowerCaseSettings "models")
|
||||||
|
|
||||||
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
|
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
|
||||||
deriving instance Eq (Unique Course)
|
deriving instance Eq (Unique Course)
|
||||||
|
|||||||
22
src/Model/Submission.hs
Normal file
22
src/Model/Submission.hs
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
module Model.Submission where
|
||||||
|
|
||||||
|
import ClassyPrelude.Yesod
|
||||||
|
import CryptoID
|
||||||
|
|
||||||
|
data SubmissionSinkException = DuplicateFileTitle FilePath
|
||||||
|
| DuplicateRating
|
||||||
|
| RatingWithoutUpdate
|
||||||
|
| ForeignRating CryptoFileNameSubmission
|
||||||
|
deriving (Typeable, Show)
|
||||||
|
|
||||||
|
instance Exception SubmissionSinkException
|
||||||
|
|
||||||
|
data SubmissionMultiSinkException
|
||||||
|
= SubmissionSinkException
|
||||||
|
{ _submissionSinkId :: CryptoFileNameSubmission
|
||||||
|
, _submissionSinkFedFile :: Maybe FilePath
|
||||||
|
, _submissionSinkException :: SubmissionSinkException
|
||||||
|
}
|
||||||
|
deriving (Typeable, Show)
|
||||||
|
|
||||||
|
instance Exception SubmissionMultiSinkException
|
||||||
@ -77,6 +77,8 @@ import Data.Data (Data)
|
|||||||
import Model.Types.Wordlist
|
import Model.Types.Wordlist
|
||||||
import Data.Text.Metrics (damerauLevenshtein)
|
import Data.Text.Metrics (damerauLevenshtein)
|
||||||
|
|
||||||
|
import qualified Database.Esqueleto as E
|
||||||
|
|
||||||
instance PathPiece UUID where
|
instance PathPiece UUID where
|
||||||
fromPathPiece = UUID.fromString . unpack
|
fromPathPiece = UUID.fromString . unpack
|
||||||
toPathPiece = pack . UUID.toString
|
toPathPiece = pack . UUID.toString
|
||||||
@ -100,8 +102,14 @@ instance ToHttpApiData (CI Text) where
|
|||||||
instance FromHttpApiData (CI Text) where
|
instance FromHttpApiData (CI Text) where
|
||||||
parseUrlPiece = fmap CI.mk . parseUrlPiece
|
parseUrlPiece = fmap CI.mk . parseUrlPiece
|
||||||
|
|
||||||
|
instance ToJSON a => ToJSON (E.Value a) where
|
||||||
|
toJSON = toJSON . E.unValue
|
||||||
|
|
||||||
|
instance FromJSON a => FromJSON (E.Value a) where
|
||||||
|
parseJSON = fmap E.Value . parseJSON
|
||||||
|
|
||||||
|
|
||||||
|
type Count = Sum Integer
|
||||||
type Points = Centi
|
type Points = Centi
|
||||||
|
|
||||||
toPoints :: Integral a => a -> Points -- deprecated
|
toPoints :: Integral a => a -> Points -- deprecated
|
||||||
@ -115,6 +123,8 @@ fromPoints = round
|
|||||||
|
|
||||||
instance DisplayAble Points
|
instance DisplayAble Points
|
||||||
|
|
||||||
|
instance DisplayAble a => DisplayAble (Sum a) where
|
||||||
|
display (Sum x) = display x
|
||||||
|
|
||||||
data SheetGrading
|
data SheetGrading
|
||||||
= Points { maxPoints :: Points }
|
= Points { maxPoints :: Points }
|
||||||
@ -129,17 +139,35 @@ deriveJSON defaultOptions
|
|||||||
} ''SheetGrading
|
} ''SheetGrading
|
||||||
derivePersistFieldJSON ''SheetGrading
|
derivePersistFieldJSON ''SheetGrading
|
||||||
|
|
||||||
|
makeLenses_ ''SheetGrading
|
||||||
|
|
||||||
|
_passingBound :: Fold SheetGrading (Either () Points)
|
||||||
|
_passingBound = folding passPts
|
||||||
|
where
|
||||||
|
passPts :: SheetGrading -> Maybe (Either () Points)
|
||||||
|
passPts (Points{}) = Nothing
|
||||||
|
passPts (PassPoints{passingPoints}) = Just $ Right passingPoints
|
||||||
|
passPts (PassBinary) = Just $ Left ()
|
||||||
|
|
||||||
gradingPassed :: SheetGrading -> Points -> Maybe Bool
|
gradingPassed :: SheetGrading -> Points -> Maybe Bool
|
||||||
gradingPassed (Points {}) _ = Nothing
|
gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
|
||||||
gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
|
where pBinary _ = pts /= 0
|
||||||
gradingPassed (PassBinary {}) pts = Just $ pts /= 0
|
pPoints b = pts >= b
|
||||||
|
|
||||||
|
|
||||||
data SheetGradeSummary = SheetGradeSummary
|
data SheetGradeSummary = SheetGradeSummary
|
||||||
{ numSheets :: Sum Int
|
{ numSheets :: Count -- Total number of sheets, includes all
|
||||||
, numGradePasses :: Sum Int
|
, numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses
|
||||||
, sumGradePoints :: Sum Points
|
, numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd
|
||||||
, achievedPasses :: Maybe (Sum Int)
|
, sumSheetsPoints :: Sum Points -- Total of all points in all sheets
|
||||||
, achievedPoints :: Maybe (Sum Points)
|
-- Marking dependend
|
||||||
|
, numMarked :: Count -- Number of already marked sheets
|
||||||
|
, numMarkedPasses :: Count -- Number of already marked sheets with passes
|
||||||
|
, numMarkedPoints :: Count -- Number of already marked sheets with points
|
||||||
|
, sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets
|
||||||
|
--
|
||||||
|
, achievedPasses :: Count -- Achieved passes (within marked sheets)
|
||||||
|
, achievedPoints :: Sum Points -- Achieved points (within marked sheets)
|
||||||
} deriving (Generic, Read, Show, Eq)
|
} deriving (Generic, Read, Show, Eq)
|
||||||
|
|
||||||
instance Monoid SheetGradeSummary where
|
instance Monoid SheetGradeSummary where
|
||||||
@ -152,20 +180,23 @@ instance Semigroup SheetGradeSummary where
|
|||||||
makeLenses_ ''SheetGradeSummary
|
makeLenses_ ''SheetGradeSummary
|
||||||
|
|
||||||
sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
|
sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
|
||||||
|
sheetGradeSum gr Nothing = mempty
|
||||||
|
{ numSheets = 1
|
||||||
|
, numSheetsPasses = bool mempty 1 $ has _passingBound gr
|
||||||
|
, numSheetsPoints = bool mempty 1 $ has _maxPoints gr
|
||||||
|
, sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
|
||||||
|
}
|
||||||
sheetGradeSum gr (Just p) =
|
sheetGradeSum gr (Just p) =
|
||||||
let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p }
|
let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
|
||||||
in case gr of PassBinary -> baseSum
|
in unmarked
|
||||||
_other -> baseSum { achievedPoints = Just $ Sum $ p }
|
{ numMarked = numSheets
|
||||||
sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1
|
, numMarkedPasses = numSheetsPasses
|
||||||
, sumGradePoints = Sum maxPoints
|
, numMarkedPoints = numSheetsPoints
|
||||||
}
|
, sumMarkedPoints = sumSheetsPoints
|
||||||
sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets = Sum 1
|
, achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p
|
||||||
, numGradePasses = Sum 1
|
, achievedPoints = bool mempty (Sum p) $ has _maxPoints gr
|
||||||
, sumGradePoints = Sum maxPoints
|
}
|
||||||
}
|
|
||||||
sheetGradeSum (PassBinary) Nothing = mempty { numSheets = Sum 1
|
|
||||||
, numGradePasses = Sum 1
|
|
||||||
}
|
|
||||||
|
|
||||||
data SheetType
|
data SheetType
|
||||||
= Normal { grading :: SheetGrading }
|
= Normal { grading :: SheetGrading }
|
||||||
@ -185,7 +216,7 @@ data SheetTypeSummary = SheetTypeSummary
|
|||||||
{ normalSummary
|
{ normalSummary
|
||||||
, bonusSummary
|
, bonusSummary
|
||||||
, informationalSummary :: SheetGradeSummary
|
, informationalSummary :: SheetGradeSummary
|
||||||
, numNotGraded :: Sum Int
|
, numNotGraded :: Count
|
||||||
} deriving (Generic, Read, Show, Eq)
|
} deriving (Generic, Read, Show, Eq)
|
||||||
|
|
||||||
instance Monoid SheetTypeSummary where
|
instance Monoid SheetTypeSummary where
|
||||||
@ -543,6 +574,7 @@ data NotificationTrigger = NTSubmissionRatedGraded
|
|||||||
| NTSheetSoonInactive
|
| NTSheetSoonInactive
|
||||||
| NTSheetInactive
|
| NTSheetInactive
|
||||||
| NTCorrectionsAssigned
|
| NTCorrectionsAssigned
|
||||||
|
| NTCorrectionsNotDistributed
|
||||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||||
|
|
||||||
instance Universe NotificationTrigger
|
instance Universe NotificationTrigger
|
||||||
@ -573,6 +605,7 @@ instance Default NotificationSettings where
|
|||||||
NTSheetSoonInactive -> False
|
NTSheetSoonInactive -> False
|
||||||
NTSheetInactive -> True
|
NTSheetInactive -> True
|
||||||
NTCorrectionsAssigned -> True
|
NTCorrectionsAssigned -> True
|
||||||
|
NTCorrectionsNotDistributed -> True
|
||||||
|
|
||||||
instance ToJSON NotificationSettings where
|
instance ToJSON NotificationSettings where
|
||||||
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
|
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
|
||||||
@ -680,7 +713,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
|
|||||||
|
|
||||||
pseudonymWords :: Fold Text PseudonymWord
|
pseudonymWords :: Fold Text PseudonymWord
|
||||||
pseudonymWords = folding
|
pseudonymWords = folding
|
||||||
$ \(CI.mk -> input) -> map (view _2) . unsafeHead . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||||
where
|
where
|
||||||
distance = damerauLevenshtein `on` CI.foldedCase
|
distance = damerauLevenshtein `on` CI.foldedCase
|
||||||
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
||||||
@ -694,6 +727,7 @@ pseudonymFragments = folding
|
|||||||
data AuthTag
|
data AuthTag
|
||||||
= AuthFree
|
= AuthFree
|
||||||
| AuthAdmin
|
| AuthAdmin
|
||||||
|
| AuthNoEscalation
|
||||||
| AuthDeprecated
|
| AuthDeprecated
|
||||||
| AuthDevelopment
|
| AuthDevelopment
|
||||||
| AuthLecturer
|
| AuthLecturer
|
||||||
|
|||||||
@ -13,6 +13,8 @@ import Data.Aeson.TH
|
|||||||
|
|
||||||
import Utils.PathPiece
|
import Utils.PathPiece
|
||||||
|
|
||||||
|
import Utils (assertM)
|
||||||
|
|
||||||
|
|
||||||
deriving instance Read Address
|
deriving instance Read Address
|
||||||
deriving instance Ord Address
|
deriving instance Ord Address
|
||||||
@ -20,6 +22,12 @@ deriving instance Generic Address
|
|||||||
|
|
||||||
instance Hashable Address
|
instance Hashable Address
|
||||||
|
|
||||||
deriveJSON defaultOptions
|
deriveToJSON defaultOptions
|
||||||
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||||
} ''Address
|
} ''Address
|
||||||
|
|
||||||
|
instance FromJSON Address where
|
||||||
|
parseJSON = withObject "Address" $ \obj -> do
|
||||||
|
addressName <- assertM (not . null) <$> (obj .:? "name")
|
||||||
|
addressEmail <- obj .: "email"
|
||||||
|
return Address{..}
|
||||||
|
|||||||
@ -59,11 +59,15 @@ import qualified Database.Memcached.Binary.Types as Memcached
|
|||||||
import Model
|
import Model
|
||||||
import Settings.Cluster
|
import Settings.Cluster
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||||
|
|
||||||
|
import qualified System.FilePath as FilePath
|
||||||
|
|
||||||
-- | Runtime settings to configure this application. These settings can be
|
-- | Runtime settings to configure this application. These settings can be
|
||||||
-- loaded from various sources: defaults, environment variables, config files,
|
-- loaded from various sources: defaults, environment variables, config files,
|
||||||
-- theoretically even a database.
|
-- theoretically even a database.
|
||||||
data AppSettings = AppSettings
|
data AppSettings = AppSettings
|
||||||
{ appStaticDir :: String
|
{ appStaticDir :: FilePath
|
||||||
-- ^ Directory from which to serve static files.
|
-- ^ Directory from which to serve static files.
|
||||||
, appDatabaseConf :: PostgresConf
|
, appDatabaseConf :: PostgresConf
|
||||||
-- ^ Configuration settings for accessing the database.
|
-- ^ Configuration settings for accessing the database.
|
||||||
@ -162,6 +166,7 @@ data LdapConf = LdapConf
|
|||||||
, ldapBase :: Ldap.Dn
|
, ldapBase :: Ldap.Dn
|
||||||
, ldapScope :: Ldap.Scope
|
, ldapScope :: Ldap.Scope
|
||||||
, ldapTimeout :: Int32
|
, ldapTimeout :: Int32
|
||||||
|
, ldapPool :: ResourcePoolConf
|
||||||
} deriving (Show)
|
} deriving (Show)
|
||||||
|
|
||||||
data SmtpConf = SmtpConf
|
data SmtpConf = SmtpConf
|
||||||
@ -248,6 +253,7 @@ instance FromJSON LdapConf where
|
|||||||
ldapBase <- Ldap.Dn <$> o .: "baseDN"
|
ldapBase <- Ldap.Dn <$> o .: "baseDN"
|
||||||
ldapScope <- o .: "scope"
|
ldapScope <- o .: "scope"
|
||||||
ldapTimeout <- o .: "timeout"
|
ldapTimeout <- o .: "timeout"
|
||||||
|
ldapPool <- o .: "pool"
|
||||||
return LdapConf{..}
|
return LdapConf{..}
|
||||||
|
|
||||||
deriveFromJSON
|
deriveFromJSON
|
||||||
@ -358,7 +364,13 @@ instance FromJSON AppSettings where
|
|||||||
appUserDefaults <- o .: "user-defaults"
|
appUserDefaults <- o .: "user-defaults"
|
||||||
appAuthPWHash <- o .: "auth-pw-hash"
|
appAuthPWHash <- o .: "auth-pw-hash"
|
||||||
|
|
||||||
appInitialInstanceID <- (o .:? "instance-id") >>= maybe (return Nothing) (\v -> Just <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v)))
|
appInitialInstanceID <- runMaybeT $ do
|
||||||
|
val <- MaybeT (o .:? "instance-id")
|
||||||
|
val' <- lift $ (Right <$> parseJSON val) <|> (Left <$> parseJSON val)
|
||||||
|
case val' of
|
||||||
|
Left fp -> guard $ FilePath.isValid fp
|
||||||
|
_ -> return ()
|
||||||
|
return val'
|
||||||
|
|
||||||
return AppSettings {..}
|
return AppSettings {..}
|
||||||
|
|
||||||
|
|||||||
28
src/Utils.hs
28
src/Utils.hs
@ -337,7 +337,7 @@ ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argu
|
|||||||
ifMaybeM Nothing dft _ = return dft
|
ifMaybeM Nothing dft _ = return dft
|
||||||
ifMaybeM (Just x) _ act = act x
|
ifMaybeM (Just x) _ act = act x
|
||||||
|
|
||||||
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
|
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespeare: one $maybe instead of $with & $if
|
||||||
maybePositive a | a > 0 = Just a
|
maybePositive a | a > 0 = Just a
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
|
|
||||||
@ -371,6 +371,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
|
|||||||
compare _ (NTop Nothing) = LT
|
compare _ (NTop Nothing) = LT
|
||||||
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
compare (NTop (Just x)) (NTop (Just y)) = compare x y
|
||||||
|
|
||||||
|
exceptTMaybe :: Monad m => ExceptT e m a -> MaybeT m a
|
||||||
|
exceptTMaybe = MaybeT . fmap (either (const Nothing) Just) . runExceptT
|
||||||
|
|
||||||
|
|
||||||
------------
|
------------
|
||||||
-- Either --
|
-- Either --
|
||||||
@ -445,6 +448,9 @@ guardM f = guard =<< f
|
|||||||
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
|
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
|
||||||
assertM f x = x >>= assertM' f
|
assertM f x = x >>= assertM' f
|
||||||
|
|
||||||
|
assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
|
||||||
|
assertM_ f x = guard . f =<< x
|
||||||
|
|
||||||
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
|
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
|
||||||
assertM' f x = x <$ guard (f x)
|
assertM' f x = x <$ guard (f x)
|
||||||
|
|
||||||
@ -492,6 +498,12 @@ partitionM crit = ofoldlM dist mempty
|
|||||||
| okay -> acc `mappend` (opoint x, mempty)
|
| okay -> acc `mappend` (opoint x, mempty)
|
||||||
| otherwise -> acc `mappend` (mempty, opoint x)
|
| otherwise -> acc `mappend` (mempty, opoint x)
|
||||||
|
|
||||||
|
mconcatMapM :: (Monoid b, Monad m, Foldable f) => (a -> m b) -> f a -> m b
|
||||||
|
mconcatMapM f = foldM (\x my -> mappend x <$> my) mempty . map f . Fold.toList
|
||||||
|
|
||||||
|
mconcatForM :: (Monoid b, Monad m, Foldable f) => f a -> (a -> m b) -> m b
|
||||||
|
mconcatForM = flip mconcatMapM
|
||||||
|
|
||||||
|
|
||||||
--------------
|
--------------
|
||||||
-- Sessions --
|
-- Sessions --
|
||||||
@ -530,6 +542,20 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
|
|||||||
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
|
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
|
||||||
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
|
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
|
||||||
|
|
||||||
|
|
||||||
|
data GlobalPostParam = PostDeleteTarget
|
||||||
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
|
|
||||||
|
instance Universe GlobalPostParam
|
||||||
|
instance Finite GlobalPostParam
|
||||||
|
nullaryPathPiece ''GlobalPostParam (camelToPathPiece' 1)
|
||||||
|
|
||||||
|
lookupGlobalPostParam :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m (Maybe result)
|
||||||
|
lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPiece ident)
|
||||||
|
|
||||||
|
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
|
||||||
|
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
|
||||||
|
|
||||||
---------------------------------
|
---------------------------------
|
||||||
-- Custom HTTP Request-Headers --
|
-- Custom HTTP Request-Headers --
|
||||||
---------------------------------
|
---------------------------------
|
||||||
|
|||||||
@ -1,6 +1,8 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||||
|
|
||||||
module Utils.Form where
|
module Utils.Form where
|
||||||
|
|
||||||
import ClassyPrelude.Yesod hiding (addMessage)
|
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
|
||||||
import Settings
|
import Settings
|
||||||
|
|
||||||
import qualified Text.Blaze.Internal as Blaze (null)
|
import qualified Text.Blaze.Internal as Blaze (null)
|
||||||
@ -15,24 +17,31 @@ import Data.Map.Lazy ((!))
|
|||||||
import qualified Data.Map.Lazy as Map
|
import qualified Data.Map.Lazy as Map
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
|
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||||
|
|
||||||
import Data.List ((!!))
|
import Data.List ((!!))
|
||||||
|
|
||||||
|
import Control.Lens
|
||||||
|
|
||||||
import Web.PathPieces
|
import Web.PathPieces
|
||||||
|
|
||||||
import Data.UUID
|
import Data.UUID
|
||||||
|
|
||||||
import Utils.Message
|
import Utils.Message
|
||||||
|
import Utils.PathPiece
|
||||||
|
|
||||||
|
import Data.Proxy
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
-- Form Renderer --
|
-- Form Renderer --
|
||||||
-------------------
|
-------------------
|
||||||
|
|
||||||
-- | Use this type to pass information to the form template
|
-- | Use this type to pass information to the form template
|
||||||
data FormLayout = FormStandard
|
data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize
|
||||||
|
|
||||||
renderAForm :: Monad m => FormLayout -> FormRender m a
|
renderAForm :: Monad m => FormLayout -> FormRender m a
|
||||||
renderAForm formLayout aform fragment = do
|
renderAForm formLayout aform fragment = do
|
||||||
(res, ($ []) -> views) <- aFormToForm aform
|
(res, ($ []) -> fieldViews) <- aFormToForm aform
|
||||||
let widget = $(widgetFile "widgets/form")
|
let widget = $(widgetFile "widgets/form")
|
||||||
return (res, widget)
|
return (res, widget)
|
||||||
|
|
||||||
@ -144,6 +153,9 @@ inputDisabled = addAttr "disabled" ""
|
|||||||
inputReadonly :: FieldSettings site -> FieldSettings site
|
inputReadonly :: FieldSettings site -> FieldSettings site
|
||||||
inputReadonly = addAttr "readonly" ""
|
inputReadonly = addAttr "readonly" ""
|
||||||
|
|
||||||
|
addAutosubmit :: FieldSettings site -> FieldSettings site
|
||||||
|
addAutosubmit = addAttr "data-autosubmit" ""
|
||||||
|
|
||||||
------------------------------------------------
|
------------------------------------------------
|
||||||
-- Unique Form Identifiers to avoid accidents --
|
-- Unique Form Identifiers to avoid accidents --
|
||||||
------------------------------------------------
|
------------------------------------------------
|
||||||
@ -163,6 +175,9 @@ data FormIdentifier
|
|||||||
| FIDSystemMessageModify
|
| FIDSystemMessageModify
|
||||||
| FIDSystemMessageModifyTranslation UUID
|
| FIDSystemMessageModifyTranslation UUID
|
||||||
| FIDSystemMessageAddTranslation
|
| FIDSystemMessageAddTranslation
|
||||||
|
| FIDDBTableFilter
|
||||||
|
| FIDDBTablePagesize
|
||||||
|
| FIDDelete
|
||||||
deriving (Eq, Ord, Read, Show)
|
deriving (Eq, Ord, Read, Show)
|
||||||
|
|
||||||
instance PathPiece FormIdentifier where
|
instance PathPiece FormIdentifier where
|
||||||
@ -194,40 +209,114 @@ class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
|
|||||||
label :: a -> WidgetT site IO ()
|
label :: a -> WidgetT site IO ()
|
||||||
label = toWidget . toPathPiece
|
label = toWidget . toPathPiece
|
||||||
|
|
||||||
|
btnValidate :: forall p. p site -> a -> Bool
|
||||||
|
btnValidate _ _ = True
|
||||||
|
|
||||||
cssClass :: a -> ButtonCssClass site
|
cssClass :: a -> ButtonCssClass site
|
||||||
|
|
||||||
|
data ButtonMessage = MsgAmbiguousButtons
|
||||||
|
| MsgWrongButtonValue
|
||||||
|
| MsgMultipleButtonValues
|
||||||
|
|
||||||
data SubmitButton = BtnSubmit
|
data SubmitButton = BtnSubmit
|
||||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||||
|
|
||||||
instance PathPiece SubmitButton where
|
instance Universe SubmitButton
|
||||||
toPathPiece = showToPathPiece
|
instance Finite SubmitButton
|
||||||
fromPathPiece = readFromPathPiece
|
|
||||||
|
|
||||||
buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
|
nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
|
||||||
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
|
|
||||||
|
buttonField :: forall a m.
|
||||||
|
( Button (HandlerSite m) a
|
||||||
|
, Show (ButtonCssClass (HandlerSite m))
|
||||||
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
, Monad m
|
||||||
|
) => a -> Field m a
|
||||||
|
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
|
||||||
|
buttonField btn = Field{..}
|
||||||
where
|
where
|
||||||
fieldEnctype = UrlEncoded
|
fieldEnctype = UrlEncoded
|
||||||
|
|
||||||
|
fieldView :: FieldViewFunc m a
|
||||||
fieldView fid name attrs _val _ = let
|
fieldView fid name attrs _val _ = let
|
||||||
cssClass' :: ButtonCssClass site
|
cssClass' :: ButtonCssClass (HandlerSite m)
|
||||||
cssClass' = cssClass btn
|
cssClass' = cssClass btn
|
||||||
|
validate = btnValidate (Proxy @(HandlerSite m)) btn
|
||||||
in [whamlet|
|
in [whamlet|
|
||||||
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
|
$newline never
|
||||||
|
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{label btn}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
fieldParse [] _ = return $ Right Nothing
|
fieldParse [] [] = return $ Right Nothing
|
||||||
fieldParse [str] _
|
fieldParse [str] []
|
||||||
| str == toPathPiece btn = return $ Right $ Just btn
|
| str == toPathPiece btn = return . Right $ Just btn
|
||||||
| otherwise = return $ Left "Wrong button value"
|
| otherwise = return . Left $ SomeMessage MsgWrongButtonValue
|
||||||
fieldParse _ _ = return $ Left "Multiple button values"
|
fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues
|
||||||
|
|
||||||
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
|
combinedButtonField :: forall a m.
|
||||||
combinedButtonField = traverse b2f
|
( Button (HandlerSite m) a
|
||||||
where
|
, Show (ButtonCssClass (HandlerSite m))
|
||||||
b2f b = aopt (buttonField b) "" Nothing
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
, MonadHandler m
|
||||||
|
) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
|
||||||
|
combinedButtonField bs FieldSettings{..} = formToAForm $ do
|
||||||
|
mr <- getMessageRender
|
||||||
|
fvId <- maybe newFormIdent return fsId
|
||||||
|
name <- maybe newFormIdent return fsName
|
||||||
|
(ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
|
||||||
|
, fsName = Just $ name <> "__" <> toPathPiece b
|
||||||
|
}) Nothing
|
||||||
|
return ( sequenceA ress
|
||||||
|
, pure FieldView
|
||||||
|
{ fvLabel = toHtml $ mr fsLabel
|
||||||
|
, fvTooltip = fmap (toHtml . mr) fsTooltip
|
||||||
|
, fvId
|
||||||
|
, fvInput = foldMap fvInput fvs
|
||||||
|
, fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
|
||||||
|
, fvRequired = False
|
||||||
|
}
|
||||||
|
)
|
||||||
|
|
||||||
submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
|
combinedButtonFieldF :: forall m a.
|
||||||
submitButton = void $ combinedButtonField [BtnSubmit]
|
( Button (HandlerSite m) a
|
||||||
|
, Show (ButtonCssClass (HandlerSite m))
|
||||||
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
, Finite a
|
||||||
|
, MonadHandler m
|
||||||
|
) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
|
||||||
|
combinedButtonFieldF = combinedButtonField (universeF :: [a])
|
||||||
|
|
||||||
|
disambiguateButtons :: forall m a.
|
||||||
|
( MonadHandler m
|
||||||
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
) => AForm m [Maybe a] -> AForm m a
|
||||||
|
disambiguateButtons = traverseAForm $ \case
|
||||||
|
(catMaybes -> [bRes]) -> return $ FormSuccess bRes
|
||||||
|
(catMaybes -> [] ) -> return FormMissing
|
||||||
|
_other -> formFailure [MsgAmbiguousButtons]
|
||||||
|
|
||||||
|
combinedButtonField_ :: forall a m.
|
||||||
|
( Button (HandlerSite m) a
|
||||||
|
, Show (ButtonCssClass (HandlerSite m))
|
||||||
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
, MonadHandler m
|
||||||
|
) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
|
||||||
|
combinedButtonField_ = (void .) . combinedButtonField
|
||||||
|
|
||||||
|
combinedButtonFieldF_ :: forall m a p.
|
||||||
|
( Button (HandlerSite m) a
|
||||||
|
, Show (ButtonCssClass (HandlerSite m))
|
||||||
|
, RenderMessage (HandlerSite m) ButtonMessage
|
||||||
|
, MonadHandler m
|
||||||
|
, Finite a
|
||||||
|
) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
|
||||||
|
combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
|
||||||
|
|
||||||
|
submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
|
||||||
|
submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
|
||||||
|
|
||||||
|
autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
|
||||||
|
autosubmitButton = combinedButtonFieldF_ (Proxy @SubmitButton) $ "" & addAutosubmit
|
||||||
|
|
||||||
-------------------
|
-------------------
|
||||||
-- Custom Fields --
|
-- Custom Fields --
|
||||||
@ -240,6 +329,12 @@ ciField :: ( Textual t
|
|||||||
) => Field m (CI t)
|
) => Field m (CI t)
|
||||||
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
|
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
|
||||||
|
|
||||||
|
pathPieceField :: ( PathPiece a
|
||||||
|
, Monad m
|
||||||
|
, RenderMessage (HandlerSite m) FormMessage
|
||||||
|
) => Field m a
|
||||||
|
pathPieceField = checkMMap (\t -> return . maybe (Left $ MsgInvalidEntry t) Right $ fromPathPiece t) toPathPiece textField
|
||||||
|
|
||||||
reorderField :: ( MonadHandler m
|
reorderField :: ( MonadHandler m
|
||||||
, HandlerSite m ~ site
|
, HandlerSite m ~ site
|
||||||
, Eq a
|
, Eq a
|
||||||
@ -295,6 +390,27 @@ optionsFinite = do
|
|||||||
-- Form evaluation --
|
-- Form evaluation --
|
||||||
---------------------
|
---------------------
|
||||||
|
|
||||||
|
traverseAForm :: forall m a b. Monad m => (a -> m (FormResult b)) -> (AForm m a -> AForm m b)
|
||||||
|
traverseAForm adj (AForm f) = AForm $ \mr env ints -> do
|
||||||
|
ret@(res, _, _, _) <- f mr env ints
|
||||||
|
case res of
|
||||||
|
FormFailure errs
|
||||||
|
-> return $ ret & _1 .~ FormFailure errs
|
||||||
|
FormMissing
|
||||||
|
-> return $ ret & _1 .~ FormMissing
|
||||||
|
FormSuccess a -> do
|
||||||
|
a' <- adj a
|
||||||
|
return $ ret & _1 .~ a'
|
||||||
|
|
||||||
|
formFailure :: forall msg m a.
|
||||||
|
( MonadHandler m
|
||||||
|
, RenderMessage (HandlerSite m) msg
|
||||||
|
) => [msg] -> m (FormResult a)
|
||||||
|
formFailure errs' = do
|
||||||
|
mr <- getMessageRender
|
||||||
|
return . FormFailure $ map mr errs'
|
||||||
|
|
||||||
|
|
||||||
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
|
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
|
||||||
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
|
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x
|
||||||
|
|
||||||
@ -302,3 +418,21 @@ formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Ma
|
|||||||
formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
|
formResultMaybe (FormFailure errs) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
|
||||||
formResultMaybe FormMissing _ = return Nothing
|
formResultMaybe FormMissing _ = return Nothing
|
||||||
formResultMaybe (FormSuccess res) f = f res
|
formResultMaybe (FormSuccess res) f = f res
|
||||||
|
|
||||||
|
formResult' :: FormResult a -> Maybe a
|
||||||
|
formResult' FormMissing = Nothing
|
||||||
|
formResult' (FormFailure _) = Nothing
|
||||||
|
formResult' (FormSuccess x) = Just x
|
||||||
|
|
||||||
|
runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a)
|
||||||
|
runInputGetMaybe form = do
|
||||||
|
res <- runInputGetResult form
|
||||||
|
return $ case res of
|
||||||
|
FormSuccess suc -> Just suc
|
||||||
|
_other -> Nothing
|
||||||
|
runInputPostMaybe form = do
|
||||||
|
res <- runInputPostResult form
|
||||||
|
return $ case res of
|
||||||
|
FormSuccess suc -> Just suc
|
||||||
|
_other -> Nothing
|
||||||
|
runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)
|
||||||
|
|||||||
16
src/Yesod/Core/Types/Instances.hs
Normal file
16
src/Yesod/Core/Types/Instances.hs
Normal file
@ -0,0 +1,16 @@
|
|||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
|
|
||||||
|
module Yesod.Core.Types.Instances
|
||||||
|
(
|
||||||
|
) where
|
||||||
|
|
||||||
|
import ClassyPrelude
|
||||||
|
import Yesod.Core.Types
|
||||||
|
|
||||||
|
import Control.Monad.Fix
|
||||||
|
|
||||||
|
instance MonadFix m => MonadFix (HandlerT site m) where
|
||||||
|
mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
|
||||||
|
|
||||||
|
instance MonadFix m => MonadFix (WidgetT site m) where
|
||||||
|
mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
|
||||||
@ -7,7 +7,7 @@ in haskell.lib.buildStackProject {
|
|||||||
inherit ghc;
|
inherit ghc;
|
||||||
name = "stackenv";
|
name = "stackenv";
|
||||||
buildInputs = (with pkgs;
|
buildInputs = (with pkgs;
|
||||||
[ postgresql zlib openldap cyrus_sasl.dev libsodium
|
[ postgresql zlib libsodium
|
||||||
]) ++ (with haskellPackages;
|
]) ++ (with haskellPackages;
|
||||||
[ yesod-bin
|
[ yesod-bin
|
||||||
]);
|
]);
|
||||||
|
|||||||
@ -29,7 +29,7 @@ extra-deps:
|
|||||||
- uuid-crypto-1.4.0.0
|
- uuid-crypto-1.4.0.0
|
||||||
- filepath-crypto-0.1.0.0
|
- filepath-crypto-0.1.0.0
|
||||||
- cryptoids-0.5.1.0
|
- cryptoids-0.5.1.0
|
||||||
- cryptoids-types-0.0.0
|
- cryptoids-types-1.0.0
|
||||||
- cryptoids-class-0.0.0
|
- cryptoids-class-0.0.0
|
||||||
|
|
||||||
- system-locale-0.3.0.0
|
- system-locale-0.3.0.0
|
||||||
|
|||||||
@ -1,5 +1,2 @@
|
|||||||
<div .container>
|
<div .container>
|
||||||
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
|
^{table}
|
||||||
^{table}
|
|
||||||
<button type=submit>
|
|
||||||
_{MsgBtnSubmit}
|
|
||||||
|
|||||||
@ -1,7 +1,4 @@
|
|||||||
<section>
|
<section>
|
||||||
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
|
^{table}
|
||||||
^{table}
|
|
||||||
<button type=submit>
|
|
||||||
_{MsgBtnSubmit}
|
|
||||||
<section>
|
<section>
|
||||||
^{statistics}
|
^{statistics}
|
||||||
@ -439,6 +439,19 @@ input[type="button"].btn-info:hover,
|
|||||||
}
|
}
|
||||||
|
|
||||||
.list--inline {
|
.list--inline {
|
||||||
|
ul {
|
||||||
|
display: inline-block;
|
||||||
|
margin-left: 0;
|
||||||
|
|
||||||
|
li {
|
||||||
|
display: inline-block;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
ul.list--inline {
|
||||||
|
|
||||||
|
display: inline-block;
|
||||||
margin-left: 0;
|
margin-left: 0;
|
||||||
|
|
||||||
li {
|
li {
|
||||||
|
|||||||
17
templates/mail/correctionsUndistributed.hamlet
Normal file
17
templates/mail/correctionsUndistributed.hamlet
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
$newline never
|
||||||
|
\<!doctype html>
|
||||||
|
<html>
|
||||||
|
<head>
|
||||||
|
<meta charset="UTF-8">
|
||||||
|
<style>
|
||||||
|
h1 {
|
||||||
|
font-size: 1.25em;
|
||||||
|
font-variant: small-caps;
|
||||||
|
font-weight: normal;
|
||||||
|
}
|
||||||
|
<body>
|
||||||
|
<h1>
|
||||||
|
_{MsgMailSubmissionsUnassignedIntro nbrSubs (CI.original courseName) termDesc sheetName}
|
||||||
|
<p>
|
||||||
|
<a href=@{CSheetR tid ssh csh shn SSubsR}>
|
||||||
|
#{sheetName}
|
||||||
@ -65,6 +65,7 @@
|
|||||||
|
|
||||||
/* TEXT INPUTS */
|
/* TEXT INPUTS */
|
||||||
input[type="text"],
|
input[type="text"],
|
||||||
|
input[type="search"],
|
||||||
input[type="password"],
|
input[type="password"],
|
||||||
input[type="url"],
|
input[type="url"],
|
||||||
input[type="number"],
|
input[type="number"],
|
||||||
|
|||||||
@ -1,8 +1,5 @@
|
|||||||
<section>
|
<section>
|
||||||
<form method=post action=@{MessageListR} encytpe=#{tableEncoding}>
|
^{tableView}
|
||||||
^{tableView}
|
|
||||||
<button type=submit>
|
|
||||||
_{MsgBtnSubmit}
|
|
||||||
|
|
||||||
<section>
|
<section>
|
||||||
<form method=post action=@{MessageListR} enctype=#{addEncoding}>
|
<form method=post action=@{MessageListR} enctype=#{addEncoding}>
|
||||||
|
|||||||
@ -2,10 +2,10 @@
|
|||||||
$maybe flag <- sortableKey
|
$maybe flag <- sortableKey
|
||||||
$case directions
|
$case directions
|
||||||
$of [SortAsc]
|
$of [SortAsc]
|
||||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-desc")}>
|
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortDesc))}>
|
||||||
^{widget}
|
^{widget}
|
||||||
$of _
|
$of _
|
||||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-asc")}>
|
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ toPathPiece (SortingSetting flag SortAsc))}>
|
||||||
^{widget}
|
^{widget}
|
||||||
$nothing
|
$nothing
|
||||||
^{widget}
|
^{widget}
|
||||||
|
|||||||
5
templates/table/form-wrap.hamlet
Normal file
5
templates/table/form-wrap.hamlet
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
$newline never
|
||||||
|
<form method=#{decodeUtf8 (renderStdMethod dbParamsFormMethod)} action=#{fromMaybe "" act} *{dbParamsFormAttrs} enctype=#{enctype'}>
|
||||||
|
^{fWidget}
|
||||||
|
$if dbParamsFormAddSubmit
|
||||||
|
^{submitView}
|
||||||
6
templates/table/layout-filter-default.hamlet
Normal file
6
templates/table/layout-filter-default.hamlet
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
$newline never
|
||||||
|
<section>
|
||||||
|
<form method=GET action=#{filterAction} enctype=#{filterEnctype}>
|
||||||
|
^{filterWgdt}
|
||||||
|
<section>
|
||||||
|
^{scrolltable}
|
||||||
@ -5,8 +5,11 @@ $else
|
|||||||
<div .scrolltable>
|
<div .scrolltable>
|
||||||
^{table}
|
^{table}
|
||||||
$if pageCount > 1
|
$if pageCount > 1
|
||||||
<ul ##{wIdent "pagination"} .pagination>
|
<div .pagination>
|
||||||
$forall p <- pageNumbers
|
<form .pagesize method=GET enctype=#{pagesizeEnc} action=#{rawAction}>
|
||||||
<li .pagination-link :p == psPage:.current>
|
^{pagesizeWdgt}
|
||||||
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
|
<ul ##{wIdent "pagination"} .pages>
|
||||||
_{MsgPage (succ p)}
|
$forall p <- pageNumbers
|
||||||
|
<li .page-link :p == psPage:.current>
|
||||||
|
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
|
||||||
|
_{MsgPage (succ p)}
|
||||||
|
|||||||
@ -10,19 +10,19 @@
|
|||||||
|
|
||||||
function setupAsync(wrapper) {
|
function setupAsync(wrapper) {
|
||||||
|
|
||||||
var table = wrapper.querySelector('#' + #{String $ dbtIdent});
|
var table = wrapper.querySelector('#' + #{String dbtIdent});
|
||||||
if (!table)
|
if (!table)
|
||||||
return;
|
return;
|
||||||
|
|
||||||
var ths = Array.from(table.querySelectorAll('th.sortable'));
|
var ths = Array.from(table.querySelectorAll('th.sortable'));
|
||||||
var pagination = wrapper.querySelector('#' + #{String $ dbtIdent} + '-pagination');
|
var pagination = wrapper.querySelector('#' + #{String dbtIdent} + '-pagination');
|
||||||
|
|
||||||
ths.forEach(function(th) {
|
ths.forEach(function(th) {
|
||||||
th.addEventListener('click', clickHandler);
|
th.addEventListener('click', clickHandler);
|
||||||
});
|
});
|
||||||
|
|
||||||
if (pagination) {
|
if (pagination) {
|
||||||
Array.from(pagination.querySelectorAll('.pagination-link'))
|
Array.from(pagination.querySelectorAll('.page-link'))
|
||||||
.forEach(function(p) {
|
.forEach(function(p) {
|
||||||
p.addEventListener('click', clickHandler);
|
p.addEventListener('click', clickHandler);
|
||||||
});
|
});
|
||||||
@ -32,12 +32,6 @@
|
|||||||
event.preventDefault();
|
event.preventDefault();
|
||||||
var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
|
var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
|
||||||
updateTableFrom(url);
|
updateTableFrom(url);
|
||||||
|
|
||||||
|
|
||||||
ths.forEach(function(th) {
|
|
||||||
// th.removeEventListener('click', clickHandler);
|
|
||||||
console.log('removed handler from', th);
|
|
||||||
});
|
|
||||||
}
|
}
|
||||||
|
|
||||||
function getClickDestination(el) {
|
function getClickDestination(el) {
|
||||||
|
|||||||
@ -1,39 +1,51 @@
|
|||||||
/* PAGINATION */
|
/* PAGINATION */
|
||||||
.pagination {
|
.pagination {
|
||||||
margin-top: 20px;
|
margin-top: 20px;
|
||||||
text-align: center;
|
display: flex;
|
||||||
|
flex-direction: row;
|
||||||
|
|
||||||
.pagination-link {
|
.pagesize {
|
||||||
margin: 0 7px;
|
float: left;
|
||||||
display: inline-block;
|
flex-grow: 0;
|
||||||
background-color: var(--color-grey);
|
|
||||||
|
|
||||||
a {
|
|
||||||
color: var(--color-lightwhite);
|
|
||||||
padding: 7px 13px;
|
|
||||||
display: inline-block;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
&:not(.current):hover {
|
.pages {
|
||||||
background-color: var(--color-lighter);
|
text-align: center;
|
||||||
|
flex-grow: 1;
|
||||||
|
margin: 0;
|
||||||
|
|
||||||
a {
|
.page-link {
|
||||||
color: var(--color-lightwhite);
|
margin: 0 7px;
|
||||||
}
|
display: inline-block;
|
||||||
|
background-color: var(--color-grey);
|
||||||
|
|
||||||
|
a {
|
||||||
|
color: var(--color-lightwhite);
|
||||||
|
padding: 7px 13px;
|
||||||
|
display: inline-block;
|
||||||
|
}
|
||||||
|
|
||||||
|
&:not(.current):hover {
|
||||||
|
background-color: var(--color-lighter);
|
||||||
|
|
||||||
|
a {
|
||||||
|
color: var(--color-lightwhite);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
&.current {
|
||||||
|
pointer-events: none;
|
||||||
|
background-color: var(--color-light);
|
||||||
|
|
||||||
|
a {
|
||||||
|
text-decoration: underline;
|
||||||
|
pointer-events: none;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
&:last-child {
|
||||||
|
margin-right: 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
&.current {
|
|
||||||
pointer-events: none;
|
|
||||||
background-color: var(--color-light);
|
|
||||||
|
|
||||||
a {
|
|
||||||
text-decoration: underline;
|
|
||||||
pointer-events: none;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
&:last-child {
|
|
||||||
margin-right: 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
}
|
||||||
|
|||||||
13
templates/widgets/delete-confirmation.hamlet
Normal file
13
templates/widgets/delete-confirmation.hamlet
Normal file
@ -0,0 +1,13 @@
|
|||||||
|
<p>_{drCaption}
|
||||||
|
<ul>
|
||||||
|
$forall (wdgt, _) <- targets
|
||||||
|
<li>
|
||||||
|
^{wdgt}
|
||||||
|
|
||||||
|
<p>_{SomeMessage $ MsgDeleteCopyStringIfSure (Set.size drRecords)}
|
||||||
|
|
||||||
|
<p .confirmationText>
|
||||||
|
#{confirmString}
|
||||||
|
|
||||||
|
<form method=POST action=@{targetRoute} enctype=#{deleteFormEnctype}>
|
||||||
|
^{deleteFormWdgt}
|
||||||
5
templates/widgets/delete-confirmation.lucius
Normal file
5
templates/widgets/delete-confirmation.lucius
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
.confirmationText {
|
||||||
|
white-space: pre-wrap;
|
||||||
|
font-size: 14px;
|
||||||
|
font-family: monospace;
|
||||||
|
}
|
||||||
@ -1,8 +1,11 @@
|
|||||||
$newline never
|
$newline never
|
||||||
#{fragment}
|
#{fragment}
|
||||||
$case formLayout
|
$case formLayout
|
||||||
$of FormStandard
|
$of FormDBTablePagesize
|
||||||
$forall view <- views
|
$forall view <- fieldViews
|
||||||
|
^{fvInput view}
|
||||||
|
$of _
|
||||||
|
$forall view <- fieldViews
|
||||||
$# TODO: add class 'form-group--submit' if this is the submit-button view
|
$# TODO: add class 'form-group--submit' if this is the submit-button view
|
||||||
<div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
|
<div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
|
||||||
$if not (Blaze.null $ fvLabel view)
|
$if not (Blaze.null $ fvLabel view)
|
||||||
|
|||||||
@ -77,7 +77,7 @@ document.addEventListener('setup', function(e) {
|
|||||||
var forms = e.detail.scope.querySelectorAll('form');
|
var forms = e.detail.scope.querySelectorAll('form');
|
||||||
Array.from(forms).forEach(function(form) {
|
Array.from(forms).forEach(function(form) {
|
||||||
// auto reactiveButton submit-buttons with required fields
|
// auto reactiveButton submit-buttons with required fields
|
||||||
var submitBtns = Array.from(form.querySelectorAll('[type=submit]'));
|
var submitBtns = Array.from(form.querySelectorAll('[type=submit]:not([formnovalidate])'));
|
||||||
submitBtns.forEach(function(submitBtn) {
|
submitBtns.forEach(function(submitBtn) {
|
||||||
window.utils.reactiveButton(form, submitBtn, validateForm);
|
window.utils.reactiveButton(form, submitBtn, validateForm);
|
||||||
});
|
});
|
||||||
@ -102,3 +102,26 @@ document.addEventListener('setup', function(e) {
|
|||||||
document.addEventListener('DOMContentLoaded', function() {
|
document.addEventListener('DOMContentLoaded', function() {
|
||||||
document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'showHide' }, bubbles: true, cancelable: true }))
|
document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'showHide' }, bubbles: true, cancelable: true }))
|
||||||
});
|
});
|
||||||
|
|
||||||
|
|
||||||
|
document.addEventListener('setup', function(e) {
|
||||||
|
if (e.detail.module && e.detail.module !== 'autoSubmit')
|
||||||
|
return;
|
||||||
|
|
||||||
|
Array.from(e.detail.scope.querySelectorAll('[data-autosubmit]:not(.js-initialized)')).forEach(function(elem) {
|
||||||
|
if ((elem instanceof HTMLInputElement && elem.type == 'submit') || (elem instanceof HTMLButtonElement && elem.type == 'submit')) {
|
||||||
|
var ancestor = elem.closest('.form-group');
|
||||||
|
var target = ancestor || elem;
|
||||||
|
|
||||||
|
target.classList.add('hidden');
|
||||||
|
} else if (elem.form) {
|
||||||
|
elem.addEventListener('change', function () { elem.form.submit() })
|
||||||
|
}
|
||||||
|
|
||||||
|
elem.classList.add('.js-initalized');
|
||||||
|
});
|
||||||
|
});
|
||||||
|
|
||||||
|
document.addEventListener('DOMContentLoaded', function() {
|
||||||
|
document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'autoSubmit' }, bubbles: true, cancelable: true }))
|
||||||
|
});
|
||||||
|
|||||||
@ -17,3 +17,8 @@ fieldset {
|
|||||||
opacity: 0;
|
opacity: 0;
|
||||||
margin: 0;
|
margin: 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
.select--pagesize {
|
||||||
|
width: 5em;
|
||||||
|
min-width: 75px;
|
||||||
|
}
|
||||||
|
|||||||
@ -1,15 +1,25 @@
|
|||||||
$# Displays gradings Summary for various purposes
|
$# Displays gradings Summary for various purposes
|
||||||
|
$# Expects several variables:
|
||||||
|
$# sumSummaries :: SheetGradeSummary -- summary over all grading types
|
||||||
|
$# hasPasses :: Maybe Int -- Should Passing be displayed?
|
||||||
|
$# hasMarkedPasses :: Maybe Int -- Number of marked pass-sheets
|
||||||
|
$# hasPoints :: Maybe Points -- Should Points be displayed?
|
||||||
|
$# hasMarkedPoints :: Maybe Int -- Number of marked point-sheets
|
||||||
$# --
|
$# --
|
||||||
<div>
|
<div>
|
||||||
<h3>_{title $ getSum $ numSheets $ sumSummaries}
|
<h3>_{MsgSummaryTitle} _{title $ getSum $ numSheets $ sumSummaries}
|
||||||
<table .table .table--striped>
|
<table .table .table--striped>
|
||||||
<tr .table__row .table__row--head>
|
<tr .table__row .table__row--head>
|
||||||
<th>
|
<th>
|
||||||
$# empty cell for row headers
|
$# empty cell for row headers
|
||||||
$maybe _ <- hasPassings
|
$maybe _ <- hasMarkedPasses
|
||||||
<th .table__th colspan=2>_{MsgSheetGradingPassing'}
|
<th .table__th colspan=2>_{MsgCorrected}
|
||||||
|
$maybe _ <- hasPasses
|
||||||
|
<th .table__th>_{MsgSheetGradingPassing'}
|
||||||
|
$maybe _ <- hasMarkedPoints
|
||||||
|
<th .table__th colspan=2>_{MsgCorrected}
|
||||||
$maybe _ <- hasPoints
|
$maybe _ <- hasPoints
|
||||||
<th .table__th colspan=2>_{MsgSheetGradingPoints'}
|
<th .table__th>_{MsgSheetGradingPoints'}
|
||||||
<th .table__th>_{MsgSheetGradingCount'}
|
<th .table__th>_{MsgSheetGradingCount'}
|
||||||
$# Number of Sheet/Submissions used for calculating maximum passes/points
|
$# Number of Sheet/Submissions used for calculating maximum passes/points
|
||||||
$forall row <- rowWdgts
|
$forall row <- rowWdgts
|
||||||
@ -17,14 +27,18 @@ $# --
|
|||||||
$maybe nrNoGrade <- positiveSum $ numNotGraded
|
$maybe nrNoGrade <- positiveSum $ numNotGraded
|
||||||
<tr .table__row>
|
<tr .table__row>
|
||||||
<th .table__th>_{MsgSheetTypeNotGraded}
|
<th .table__th>_{MsgSheetTypeNotGraded}
|
||||||
$maybe _ <- hasPassings
|
$maybe _ <- hasMarkedPasses
|
||||||
<td colspan=2>
|
<td colspan=2>
|
||||||
$maybe _ <- hasPoints
|
$maybe _ <- hasPasses
|
||||||
|
<td .table__td>
|
||||||
|
$maybe _ <- hasMarkedPoints
|
||||||
<td .table__td colspan=2>
|
<td .table__td colspan=2>
|
||||||
|
$maybe _ <- hasPoints
|
||||||
|
<td .table__td>
|
||||||
<td .table__td>#{display nrNoGrade}
|
<td .table__td>#{display nrNoGrade}
|
||||||
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
|
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
|
||||||
<p>_{MsgSheetTypeInfoBonus}
|
<p>_{MsgSheetTypeInfoBonus} #
|
||||||
$maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
|
$maybe _ <- positiveSum $ bonusSummary ^. _achievedPoints
|
||||||
_{MsgSheetGradingBonusIncluded}
|
_{MsgSheetGradingBonusIncluded}
|
||||||
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
|
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
|
||||||
<p>_{MsgSheetTypeInfoNotGraded}
|
<p>_{MsgSheetTypeInfoNotGraded}
|
||||||
|
|||||||
@ -1,33 +1,54 @@
|
|||||||
$# Displays one row of the grading summary
|
$# Displays one row of the grading summary
|
||||||
$# Expects several variables:
|
$# Expects several variables:
|
||||||
$# hasPassing :: Maybe Int -- Should Passing be displayed?
|
|
||||||
$# hasPoints :: Maybe Poibts -- Should Points be displayed?
|
|
||||||
$# summary :: SheetGradeSummary -- summary to display
|
$# summary :: SheetGradeSummary -- summary to display
|
||||||
$# sumHeader :: UniWorXMessage -- row header
|
$# sumHeader :: UniWorXMessage -- row header
|
||||||
|
$# hasPasses :: Maybe Int -- Should Passing be displayed?
|
||||||
|
$# hasMarkedPasses :: Maybe Int -- Number of marked pass-sheets
|
||||||
|
$# hasPoints :: Maybe Points -- Should Points be displayed?
|
||||||
|
$# hasMarkedPoints :: Maybe Int -- Number of marked point-sheets
|
||||||
$#
|
$#
|
||||||
$maybe nrSheets <- positiveSum $ summary ^. _numSheets
|
$# TODO: Durschnittliche Punktzahl anzeigen
|
||||||
<tr .table__row >
|
$# TODO: Extra-Spalte für Punkte Bewertet = numMarkedPoints / Punkte Gesamt = sumSheetPoints
|
||||||
|
$#
|
||||||
|
$maybe _ <- positiveSum $ summary ^. _numSheets
|
||||||
|
<tr .table__row>
|
||||||
<th .table__th>_{sumHeader}
|
<th .table__th>_{sumHeader}
|
||||||
$maybe _ <- hasPassings
|
$maybe _ <- hasMarkedPasses
|
||||||
$with Sum pmax <- summary ^. _numGradePasses
|
$with Sum pmax <- summary ^. _numMarkedPasses
|
||||||
$maybe Sum pacv <- summary ^. _achievedPasses
|
$if pmax > 0
|
||||||
|
$with Sum pacv <- summary ^. _achievedPasses
|
||||||
<td .table__td>
|
<td .table__td>
|
||||||
$if pmax /= 0
|
$if pmax > 0
|
||||||
#{textPercentInt pacv pmax}
|
#{textPercentInt pacv pmax}
|
||||||
<td .table__td>
|
<td .table__td>
|
||||||
#{display pacv} / #{display pmax}
|
#{display pacv} / #{display pmax}
|
||||||
$nothing
|
$else
|
||||||
<td .table__td colspan=2>
|
<td .table__td>
|
||||||
#{display pmax }
|
<td .table__td>
|
||||||
|
$maybe _ <- hasPasses
|
||||||
|
$with Sum numPass <- summary ^. _numSheetsPasses
|
||||||
|
<td .table__td>
|
||||||
|
$if numPass > 0
|
||||||
|
#{display numPass}
|
||||||
|
$maybe _ <- hasMarkedPoints
|
||||||
|
$with Sum pmax <- summary ^. _sumMarkedPoints
|
||||||
|
$with Sum pacv <- summary ^. _achievedPoints
|
||||||
|
<td .table__td>
|
||||||
|
$if pmax > 0
|
||||||
|
#{textPercent $ realToFrac $ pacv / pmax}
|
||||||
|
<td .table__td>
|
||||||
|
#{display pacv} / #{display pmax}
|
||||||
|
$if ((summary ^. _numMarkedPoints) /= (summary ^. _numSheets))
|
||||||
|
$# Falls Anzahl Blätter der Zeile verschieden von Anzahl gewerterer Blätter
|
||||||
|
\ (_{title $ getSum $ summary ^. _numMarkedPoints})
|
||||||
|
$# Kurze Alternative mit Hashtag-Symbol für "Anzahl"
|
||||||
|
$# \ (##{display $ summary ^. _numMarkedPoints})
|
||||||
$maybe _ <- hasPoints
|
$maybe _ <- hasPoints
|
||||||
$with Sum pmax <- summary ^. _sumGradePoints
|
<td .table__td>
|
||||||
$maybe Sum pacv <- summary ^. _achievedPoints
|
#{display (summary ^. _sumSheetsPoints)}
|
||||||
<td .table__td>
|
$if ((summary ^. _numSheetsPoints) /= (summary ^. _numSheets))
|
||||||
$if pmax /= 0
|
$# Falls Anzahl Blätter der Zeile verschieden von Anzahl Blätter mit Punkten
|
||||||
#{textPercent $ realToFrac $ pacv / pmax}
|
\ (_{title $ getSum $ summary ^. _numSheetsPoints})
|
||||||
<td .table__td>
|
$# Kurze Alternative mit Hashtag-Symbol für "Anzahl"
|
||||||
#{display pacv} / #{display pmax}
|
$# \ (##{display $ summary ^. _numSheetsPoints})
|
||||||
$nothing
|
<td .table__td>#{display $ summary ^. _numSheets}
|
||||||
<td .table__td colspan=2>
|
|
||||||
#{display pmax }
|
|
||||||
<td .table__td>#{display nrSheets}
|
|
||||||
@ -1,41 +0,0 @@
|
|||||||
$# DEPRECATED IN FAVOUR OF widgets/gradingSummary.hamlet DO NOT USE !!!
|
|
||||||
$with realGrades <- normalSummary <> bonusSummary
|
|
||||||
$# $with allGrades <- realGrades <> informationalSummary
|
|
||||||
<div>
|
|
||||||
$maybe realPoints <- positiveSum (sumGradePoints realGrades)
|
|
||||||
<p>
|
|
||||||
Gesamtpunktzahl #{display realPoints}
|
|
||||||
$maybe nPts <- getSum <$> achievedPoints realGrades
|
|
||||||
\ davon #{display nPts} erreicht
|
|
||||||
$maybe bPts <- getSum <$> achievedPoints bonusSummary
|
|
||||||
\ (inklusive #{display bPts} #
|
|
||||||
$maybe achievedBonus <- positiveSum (sumGradePoints bonusSummary)
|
|
||||||
von #{display achievedBonus} erreichbaren #
|
|
||||||
Bonuspunkten)
|
|
||||||
$if realPoints /= 0
|
|
||||||
\ #{textPercent $ realToFrac $ nPts / realPoints}
|
|
||||||
\.
|
|
||||||
$maybe fakePoints <- positiveSum (sumGradePoints informationalSummary)
|
|
||||||
<p>
|
|
||||||
<em>Hinweis:
|
|
||||||
\ #{display fakePoints} Punkte gab es für Aufgabenblätter, #
|
|
||||||
welche nicht gewertet wurden, sondern nur informativen Charakter besitzen
|
|
||||||
$maybe achievedFakes <- getSum <$> achievedPoints informationalSummary
|
|
||||||
, davon wurden #{display achievedFakes} erreicht
|
|
||||||
$if fakePoints /= 0
|
|
||||||
\ #{textPercent $ realToFrac $ achievedFakes / fakePoints}
|
|
||||||
\.
|
|
||||||
|
|
||||||
$maybe reqPasses <- positiveSum (numGradePasses normalSummary)
|
|
||||||
<p>
|
|
||||||
Aufgaben zum Bestehen: #{display reqPasses}
|
|
||||||
$maybe passed <- getSum <$> achievedPasses realGrades
|
|
||||||
\ davon #{display passed} bestanden
|
|
||||||
$maybe bonusPassed <- getSum <$> achievedPasses bonusSummary
|
|
||||||
\ (inklusive #{display bonusPassed} Bonusaufgaben)
|
|
||||||
\.
|
|
||||||
|
|
||||||
$maybe noGradeSheets <- positiveSum numNotGraded
|
|
||||||
<p>
|
|
||||||
#{display noGradeSheets} unbewertete Aufgabenblätter.
|
|
||||||
|
|
||||||
@ -237,11 +237,11 @@ fillDb = do
|
|||||||
void . insert $ DegreeCourse ffp sdMst sdInf
|
void . insert $ DegreeCourse ffp sdMst sdInf
|
||||||
void . insert $ Lecturer jost ffp
|
void . insert $ Lecturer jost ffp
|
||||||
void . insert $ Lecturer gkleen ffp
|
void . insert $ Lecturer gkleen ffp
|
||||||
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
|
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
|
||||||
insert_ $ SheetEdit gkleen now adhoc
|
insert_ $ SheetEdit gkleen now adhoc
|
||||||
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
|
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
|
||||||
insert_ $ SheetEdit gkleen now feste
|
insert_ $ SheetEdit gkleen now feste
|
||||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
|
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions False
|
||||||
insert_ $ SheetEdit gkleen now keine
|
insert_ $ SheetEdit gkleen now keine
|
||||||
-- EIP
|
-- EIP
|
||||||
eip <- insert' Course
|
eip <- insert' Course
|
||||||
@ -330,6 +330,7 @@ fillDb = do
|
|||||||
, sheetUploadMode = Upload True
|
, sheetUploadMode = Upload True
|
||||||
, sheetHintFrom = Nothing
|
, sheetHintFrom = Nothing
|
||||||
, sheetSolutionFrom = Nothing
|
, sheetSolutionFrom = Nothing
|
||||||
|
, sheetAutoDistribute = True
|
||||||
}
|
}
|
||||||
void . insert $ SheetEdit jost now sh1
|
void . insert $ SheetEdit jost now sh1
|
||||||
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
|
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do
|
||||||
|
|||||||
Reference in New Issue
Block a user