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

Merge branch 'master' into 'live'

Browse Source 
Master

Closes #259 and #253

See merge request !122
This commit is contained in:
Gregor Kleen 2018-12-29 14:00:57 +01:00
commit bf50ceef8f
91 changed files with 2269 additions and 1072 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
README.md
View File

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

5
config/keter_testworx.yml
View File

@ -27,7 +27,10 @@ stanzas:
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPSEARCHTIME
- LDAPSTRIPES
- LDAPTIMEOUT
- LDAPLIMIT
- DUMMY_LOGIN
- DETAILED_LOGGING
- LOG_ALL
@ -46,6 +49,8 @@ stanzas:
- SMTPPASS
- SMTPTIMEOUT
- SMTPLIMIT
- MAILSUPPORT
- MAILSUPPORT_NAME
- INSTANCE_ID
- MEMCACHEDHOST
- MEMCACHEDPORT

5
config/keter_uni2work.yml
View File

@ -27,7 +27,10 @@ stanzas:
- LDAPPASS
- LDAPBASE
- LDAPSCOPE
- LDAPSEARCHTIME
- LDAPSTRIPES
- LDAPTIMEOUT
- LDAPLIMIT
- DETAILED_LOGGING
- LOG_ALL
- LOGLEVEL
@ -45,6 +48,8 @@ stanzas:
- SMTPPASS
- SMTPTIMEOUT
- SMTPLIMIT
- MAILSUPPORT
- MAILSUPPORT_NAME
- INSTANCE_ID
- MEMCACHEDHOST
- MEMCACHEDPORT

10
config/settings.yml
View File

@ -16,8 +16,8 @@ mail-verp:
separator: "+"
at-replacement: "="
mail-support:
name: null
email: "uni2work@ifi.lmu.de"
name: "_env:MAILSUPPORT_NAME:"
email: "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
job-workers: "_env:JOB_WORKERS:10"
job-flush-interval: "_env:JOB_FLUSH:30"
@ -66,7 +66,11 @@ ldap:
pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:"
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:
host: "_env:SMTPHOST:"

3
messages/button/de.msg Normal file
View File

@ -0,0 +1,3 @@
AmbiguousButtons: Mehrere Submit-Buttons aktiv
WrongButtonValue: Submit-Button hat falschen Wert
MultipleButtonValues: Submit-Button hat mehrere Werte

3
messages/dummy/de.msg
View File

@ -1 +1,2 @@
DummyIdent: Nutzer-Kennung
DummyIdent: Nutzer-Kennung
DummyNoFormData: Keine Formulardaten empfangen

60
messages/uniworx/de.msg
View File

@ -69,9 +69,13 @@ CourseSemester: Semester
CourseSchool: Institut
CourseSchoolShort: Fach
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
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.
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
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}.
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
SheetDelHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen? Alle assoziierten Abgaben und Korrekturen gehen ebenfalls verloren!
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetDelHasSubmissions objs@Int: Inkl. #{tshow objs} #{pluralDE objs "Abgabe" "Abgaben"}!
SheetDeleteQuestion: Wollen Sie das unten aufgeführte Übungsblatt und alle zugehörigen Abgaben wirklich löschen?
SheetDeleted: Übungsblatt gelöscht
SheetUploadMode: Abgabe von Dateien
SheetSubmissionMode: Abgabe-Modus
@ -138,6 +145,9 @@ SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien
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
CorrectionsTitle: Zugewiesene Korrekturen
@ -151,6 +161,7 @@ UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter 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
SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion
AutoAssignCorrs: Korrekturen am Ende der Abgabefrist automatisch zuteilen
Corrector: Korrektor
Correctors: Korrektoren
CorState: Status
@ -226,13 +238,18 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
NrColumn: Nr
SelectColumn: Auswahl
DBTablePagesize: Einträge
DBTablePagesizeAll: Alle
CorrDownload: Herunterladen
CorrUploadField: Korrekturen
CorrUpload: Korrekturen hochladen
CorrSetCorrector: Korrektor zuweisen
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:
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
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
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
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
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
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
MailSubjectSupport: Supportanfrage
@ -390,11 +420,12 @@ SheetTypeBonus grading@SheetGrading: Bonus
SheetTypeNormal grading@SheetGrading: Normal
SheetTypeInformational grading@SheetGrading: Keine Wertung
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.
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.
SheetGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Blätter
SubmissionGradingSummaryTitle n@Int: Zusammenfassung über alle #{display n} Abgaben
SummaryTitle: Zusammenfassung über
SheetGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Blatt" "Blätter"}
SubmissionGradingSummaryTitle intgr@Integer: #{display intgr} #{pluralDE intgr "Abgabe" "Abgaben"}
SheetTypeBonus': Bonus
SheetTypeNormal': Normal
@ -417,6 +448,7 @@ NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
NotificationTriggerCorrectionsNotDistributed: Abgaben eines meiner Übungsblätter konnten keinem Korrektur zugeteilt werden
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -518,6 +550,7 @@ MenuLogout: Logout
MenuCourseList: Kurse
MenuTermShow: Semester
MenuCorrection: Korrektur
MenuSubmissionDelete: Abgabe löschen
MenuUsers: Benutzer
MenuAdminTest: Admin-Demo
MenuMessageList: Systemnachrichten
@ -531,18 +564,21 @@ MenuCorrections: Abgaben
MenuSheetNew: Neues Übungsblatt anlegen
MenuCourseEdit: Kurs editieren
MenuCourseNewTemplate: Als neuen Kurs klonen
MenuCourseDelete: Kurs löschen
MenuSubmissionNew: Abgabe anlegen
MenuSubmissionOwn: Abgabe
MenuCorrectors: Korrektoren
MenuSheetEdit: Übungsblatt editieren
MenuSheetDelete: Übungsblatt löschen
MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten
AuthPredsActive: Aktive Authorisierungsprädikate
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
AuthTagFree: Seite ist generell zugänglich
AuthTagFree: Seite ist universell zugänglich
AuthTagAdmin: Nutzer ist Administrator
AuthTagNoEscalation: Nutzer-Rechte werden nicht erweitert
AuthTagDeprecated: Seite ist nicht überholt
AuthTagDevelopment: Seite ist nicht in Entwicklung
AuthTagLecturer: Nutzer ist Dozent
@ -558,4 +594,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
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
View File

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

@ -0,0 +1,4 @@
ClusterConfig
setting ClusterSettingsKey
value Value
Primary setting

40
models/courses Normal file
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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
View 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

2
package.yaml
View File

@ -112,6 +112,7 @@ dependencies:
- text-metrics
- pkcs7
- memcached-binary
- directory-tree
other-extensions:
- GeneralizedNewtypeDeriving
@ -162,6 +163,7 @@ default-extensions:
- PolyKinds
- PackageImports
- TypeApplications
- RecursiveDo
ghc-options:
- -Wall

6
routes
View File

@ -36,7 +36,7 @@
/users UsersR GET -- no tags, i.e. admins only
/admin/test AdminTestR GET POST
/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
/info VersionR GET !free
/help HelpR GET POST !free
@ -60,7 +60,6 @@
-- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer
!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand} CourseNewTemplateR GET !lecturer
/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free
/register CRegisterR POST !timeANDcapacity
@ -80,8 +79,9 @@
!/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
!/subs/own SubmissionOwnR GET !free -- just redirect
/subs/#CryptoFileNameSubmission SubmissionR:
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
/delete SubDelR GET POST !ownerANDtime
/assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector

7
src/Application.hs
View File

@ -139,13 +139,14 @@ makeFoundation appSettings@AppSettings{..} = do
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool appSmtpPool 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
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
tempFoundation = mkFoundation
(error "connPool forced in tempFoundation")
(error "smtpPool forced in tempFoundation")
(error "ldapPool forced in tempFoundation")
(error "cryptoIDKey forced in tempFoundation")
(error "sessionKey forced in tempFoundation")
(error "secretBoxKey forced in tempFoundation")
@ -166,6 +167,8 @@ makeFoundation appSettings@AppSettings{..} = do
sqlPool <- createPostgresqlPool
(pgConnStr 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.
migrateAll `runSqlPool` sqlPool
@ -173,7 +176,7 @@ makeFoundation appSettings@AppSettings{..} = do
appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `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

7
src/Auth/Dummy.hs
View File

@ -13,10 +13,12 @@ import qualified Data.CaseInsensitive as CI
data DummyMessage = MsgDummyIdent
| MsgDummyNoFormData
dummyForm :: ( RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, Button site SubmitButton
@ -33,6 +35,7 @@ dummyLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AuthPlugin site
@ -46,7 +49,9 @@ dummyLogin = AuthPlugin{..}
FormFailure errs -> do
lift . forM_ errs $ addMessage Error . toHtml
redirect LoginR
FormMissing -> redirect LoginR
FormMissing -> do
lift $ addMessageI Warning MsgDummyNoFormData
redirect LoginR
FormSuccess ident ->
lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
apDispatch _ _ = notFound

15
src/Auth/LDAP.hs
View File

@ -17,6 +17,7 @@ import qualified Control.Monad.Catch as Exc
import Utils.Form
import Ldap.Client (Ldap)
import qualified Ldap.Client as Ldap
import qualified Data.Text.Encoding as Text
@ -36,7 +37,7 @@ data CampusMessage = MsgCampusIdentNote
| 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
where
userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
@ -52,6 +53,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AForm (HandlerT site IO) CampusLogin
@ -64,10 +66,11 @@ campusLogin :: forall site.
( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => LdapConf -> AuthPlugin site
campusLogin conf@LdapConf{..} = AuthPlugin{..}
) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
where
apName = "LDAP"
apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
@ -79,7 +82,7 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
redirect LoginR
FormMissing -> redirect LoginR
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 ldapDn ldapPassword
findUser conf ldap campusIdent [userPrincipalName]
@ -117,8 +120,8 @@ data CampusUserException = CampusUserLdapError Ldap.LdapError
instance Exception CampusUserException
campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
campusUser :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
Ldap.bind ldap ldapDn ldapPassword
results <- case lookup "DN" credsExtra of
Just userDN -> do

2
src/Auth/PWHash.hs
View File

@ -27,6 +27,7 @@ data PWHashMessage = MsgPWHashIdent
hashForm :: ( RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => AForm (HandlerT site IO) HashLogin
@ -41,6 +42,7 @@ hashLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
) => PWHashAlgorithm -> AuthPlugin site

12
src/CryptoID.hs
View File

@ -25,6 +25,9 @@ import Web.PathPieces
import Data.CaseInsensitive (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
decCryptoIDs [ ''SubmissionId
@ -41,6 +44,15 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
return . CryptoID . CI.mk $ map CI.original piece'
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)
deriving (Show, Read, Eq)

9
src/Data/CaseInsensitive/Instances.hs
View File

@ -1,3 +1,4 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.CaseInsensitive.Instances
@ -12,6 +13,7 @@ import qualified Data.CaseInsensitive as CI
import Database.Persist.Sql
import Text.Blaze (ToMarkup(..))
import Text.Shakespeare.Text (ToText(..))
import Data.Text (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 qualified Database.Esqueleto as E
instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
@ -37,6 +41,8 @@ instance PersistFieldSql (CI Text) where
instance PersistFieldSql (CI String) where
sqlType _ = SqlOther "citext"
instance (E.SqlString a, PersistField (CI a)) => E.SqlString (CI a)
instance ToJSON a => ToJSON (CI a) where
toJSON = toJSON . CI.original
@ -58,6 +64,9 @@ instance ToMarkup a => ToMarkup (CI a) where
toMarkup = toMarkup . 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
toWidget = toWidget . CI.original

19
src/Data/Monoid/Instances.hs Normal file
View 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
View 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

78
src/Foundation.hs
View File

@ -102,6 +102,7 @@ data UniWorX = UniWorX
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appLdapPool :: Maybe LdapPool
, appWidgetMemcached :: Maybe Memcached.Connection
, appHttpManager :: Manager
, appLogger :: (ReleaseKey, TVar Logger)
@ -145,11 +146,22 @@ pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Cr
pattern CSubmissionR tid ssh csh shn 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
mkMessage "UniWorX" "messages/uniworx" "de"
mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "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
-- achieve customized and internationalized form validation messages.
@ -198,6 +210,7 @@ embedRenderMessage ''UniWorX ''StudyFieldType id
embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>)
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>)
@ -360,6 +373,16 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
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
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute
@ -479,8 +502,11 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ registered <= 0
assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
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
r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
@ -1178,7 +1204,15 @@ pageActions (CourseR tid ssh csh CShowR) =
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseNewTemplate
, 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
, menuItemAccessCallback' = return True
}
@ -1242,6 +1276,14 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemModal = False
, 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) =
[ MenuItem
@ -1270,6 +1312,24 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemModal = 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) =
[ MenuItem
@ -1581,11 +1641,11 @@ instance YesodAuth UniWorX where
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
$logDebugS "auth" $ tshow Creds{..}
AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings
UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
flip catches excHandlers $ case appLdapConf of
Just ldapConf -> fmap (either id id) . runExceptT $ do
ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do
ldapData <- campusUser ldapConf ldapPool $ Creds credsPlugin (CI.original userIdent) credsExtra
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
let
@ -1669,8 +1729,8 @@ instance YesodAuth UniWorX where
where
insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ())
authPlugins (appSettings -> AppSettings{..}) = catMaybes
[ campusLogin <$> appLdapConf
authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes
[ campusLogin <$> appLdapConf <*> appLdapPool
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
, dummyLogin <$ guard appAuthDummyLogin
]

137
src/Handler/Corrections.hs
View File

@ -8,6 +8,7 @@ import Handler.Utils
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete
-- import Handler.Utils.Zip
import Utils.Lens
@ -39,8 +40,6 @@ import qualified Database.Esqueleto as E
-- import Network.Mime
import Web.PathPieces
import Text.Hamlet (ihamletFile)
import Database.Persist.Sql (updateWhereCount)
@ -127,8 +126,8 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSelect :: forall act h. (Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect _2 id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
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")]
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 _ (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 = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
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 = sortable Nothing (i18nCell MsgRatingComment) $ formCell
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell id
(\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))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
=> CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> DBParams m x -> DB (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' dbtParams = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery = correctionsTableQuery whereClause
(\((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)
dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
, dbtColonnade
, dbtProj
, dbtSorting = Map.fromList
@ -248,10 +248,9 @@ makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
E.sub_select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
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
return (user E.^. UserDisplayName)
return (user E.^. UserSurname)
)
]
, 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)
)
]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams
, dbtIdent = "corrections" :: Text
}
data ActionCorrections = CorrDownload
| CorrSetCorrector
| CorrAutoSetCorrector
| CorrDelete
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance PathPiece ActionCorrections where
fromPathPiece = readFromPathPiece
toPathPiece = showToPathPiece
instance RenderMessage UniWorX ActionCorrections where
renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
instance Universe ActionCorrections
instance Finite ActionCorrections
nullaryPathPiece ''ActionCorrections $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ActionCorrections id
data ActionCorrectionsData = CorrDownloadData
| CorrSetCorrectorData (Maybe UserId)
| CorrAutoSetCorrectorData SheetId
| CorrDeleteData
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
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
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
FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
FormMissing -> return ()
@ -377,13 +399,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
unassigned' <- forM (Set.toList stillUnassigned) $ \sid -> encrypt sid :: DB CryptoFileNameSubmission
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
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
setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections")
@ -403,10 +425,13 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
downloadAction :: ActionCorrections'
downloadAction, deleteAction :: ActionCorrections'
downloadAction = ( CorrDownload
, pure CorrDownloadData
)
deleteAction = ( CorrDelete
, pure CorrDeleteData
)
assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
@ -478,6 +503,7 @@ postCCorrectionsR tid ssh csh = do
correctionsR whereClause colonnade psValidator $ Map.fromList
[ downloadAction
, assignAction (Left cid)
, deleteAction
]
getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
@ -501,6 +527,7 @@ postSSubsR tid ssh csh shn = do
[ downloadAction
, assignAction (Right shid)
, autoAssignAction shid
, deleteAction
]
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
@ -579,13 +606,12 @@ postCorrectionR tid ssh csh shn cid = do
FormSuccess fileUploads -> do
uid <- requireAuthId
void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
{-case res of
(Left _) -> addMessageI Success MsgRatingFilesUpdated
(Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected
(Right other) -> throw other-}
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
mr <- getMessageRender
let sheetTypeDesc = mr sheetType
@ -620,13 +646,15 @@ postCorrectionsUploadR = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess files -> do
uid <- requireAuthId
subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
if
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
| otherwise -> do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
case mbSubs of
Nothing -> return ()
(Just subs)
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
| otherwise -> do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $
@ -670,7 +698,7 @@ postCorrectionsCreateR = do
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, (pss, invalids)) -> do
allDone <- fmap getAll . execWriterT $ do
allDone <- fmap getAll . execWriterT $ do
forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet")
tell . All $ null invalids
@ -794,14 +822,17 @@ postCorrectionsGradeR = do
, colCommentField
] -- Continue here
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)
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
cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
return i
((fmap unFormResult -> tableRes, table), tableEncoding) <- runFormPost tableForm
(fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns psValidator dbtProj' $ def
{ dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR
, dbParamsFormAddSubmit = True
}
case tableRes of
FormMissing -> return ()

64
src/Handler/Course.hs
View File

@ -1,23 +1,25 @@
module Handler.Course where
import Import hiding (catMaybes)
import Import
import Utils.Lens
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells
import Handler.Utils.Course
import Handler.Utils.Delete
-- import Data.Time
import qualified Data.Text as T
import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
import Data.Maybe
import Data.Monoid (Last(..))
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI
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)
snd <$> dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtColonnade = colChoices
, dbtProj
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
@ -161,13 +164,28 @@ makeCourseTable whereClause colChoices psValidator = do
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| 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
}
getCourseListR :: Handler Html
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
getCourseListR = do
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourseDescr
@ -178,11 +196,10 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
]
whereClause = const $ E.val True
validator = def
& defaultSorting [("course", SortAsc), ("term", SortDesc)]
& defaultSorting [SortAscBy "course", SortDescBy "term"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI MsgCourseListTitle
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
$(widgetFile "courses")
getTermCurrentR :: Handler Html
@ -210,7 +227,7 @@ getTermSchoolCourseListR tid ssh = do
course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def
& defaultSorting [("cshort", SortAsc)]
& defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI $ MsgTermSchoolCourseListTitle tid school
@ -232,7 +249,7 @@ getTermCourseListR tid = do
]
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
validator = def
& defaultSorting [("cshort", SortAsc)]
& defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid
@ -299,13 +316,6 @@ postCRegisterR tid ssh csh = do
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 = do
uid <- requireAuthId
@ -378,18 +388,14 @@ pgCEditR isGetReq tid ssh csh = do
courseEditHandler isGetReq $ courseToForm <$> course
getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = error "TODO: implement getCDeleteR"
postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCDeleteR = error "TODO: implement getCDeleteR"
{- TODO
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
, Just cid <- cfCourseId res -> do
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
-}
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = postCDeleteR
postCDeleteR tid ssh csh = do
Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
deleteR $ (courseDeleteRoute $ Set.singleton cId)
{ drAbort = SomeRoute $ CourseR tid ssh csh CShowR
, drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
}
-- | Course Creation and Editing

16
src/Handler/Home.hs
View File

@ -75,6 +75,7 @@ homeAnonymous = do
]
courseTable <- runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = (E.^. CourseId)
, dbtColonnade = colonnade
, dbtProj = return
, dbtSorting = Map.fromList
@ -97,7 +98,9 @@ homeAnonymous = do
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
] -}
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text
}
-- let features = $(widgetFile "featureList")
@ -166,9 +169,10 @@ homeUser uid = do
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark
]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
let validator = def & defaultSorting [SortDescBy "done", SortDescBy "deadline"]
sheetTable <- runDB $ dbTableWidget' validator DBTable
{ dbtSQLQuery = tableData
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtColonnade = colonnade
, 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)
@ -198,7 +202,9 @@ homeUser uid = do
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
] -}
, dbtFilterUI = mempty
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtParams = def
, dbtIdent = "upcomingdeadlines" :: Text
}
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
@ -283,8 +289,12 @@ getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
(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
$ AuthTagActive

31
src/Handler/Profile.hs
View File

@ -106,9 +106,9 @@ postProfileDataR = do
defaultLayout
$(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do
addMessageI Info MsgAborted
redirect ProfileDataR
-- (FormSuccess BtnAbort ) -> do
-- addMessageI Info MsgAborted
-- redirect ProfileDataR
_other -> getProfileDataR
@ -247,6 +247,7 @@ mkOwnedCoursesTable =
, course E.^. CourseSchool
, 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)))
dbtColonnade = mconcat
@ -262,7 +263,7 @@ mkOwnedCoursesTable =
courseCellCL <$> view _dbrOutput
]
validator = def & defaultSorting [ ("term", SortDesc), ("school", SortAsc), ("course", SortAsc) ]
validator = def & defaultSorting [ SortDescBy "term", SortAscBy "school", SortAscBy "course" ]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
, ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm )
@ -273,6 +274,8 @@ mkOwnedCoursesTable =
, ( "term", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm )
, ( "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{..}
@ -284,7 +287,7 @@ mkEnrolledCoursesTable =
-> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
withType = id
validator = def & defaultSorting [("time",SortDesc)]
validator = def & defaultSorting [SortDescBy "time"]
in \uid -> dbTableWidget' validator
DBTable
@ -293,6 +296,7 @@ mkEnrolledCoursesTable =
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
return (course, participant E.^. CourseParticipantRegistration)
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtProj = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
, dbtColonnade = mconcat
[ dbRow
@ -319,7 +323,9 @@ mkEnrolledCoursesTable =
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
-- , ( "time" , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
}
@ -345,6 +351,7 @@ mkSubmissionTable =
)
let sht = sheet E.^. SheetName
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
E.sub_select . E.from $ \subEdit -> do
@ -383,7 +390,7 @@ mkSubmissionTable =
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
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
& defaultSorting [SortDescBy "edit"]
dbtSorting' uid = Map.fromList
[ ( "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 )
@ -396,6 +403,8 @@ mkSubmissionTable =
, ( "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 )
]
dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
dbtSorting = dbtSorting' uid
in dbTableWidget' validator DBTable{..}
@ -423,6 +432,7 @@ mkSubmissionGroupTable =
, course E.^. CourseShorthand
)
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
E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
@ -452,7 +462,7 @@ mkSubmissionGroupTable =
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
& restrictSorting (\name _ -> name /= "corrector")
& defaultSorting [("edit",SortDesc)]
& defaultSorting [SortDescBy "edit"]
dbtSorting = Map.fromList
[ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
, ( "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 )
, ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool )
]
dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}
@ -500,6 +512,7 @@ mkCorrectionsTable =
, course E.^. CourseShorthand
)
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
& _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)
]
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
[ ( "term" , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm )
, ( "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 )
, ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
]
dbtFilterUI = mempty
dbtParams = def
in \uid -> let dbtSQLQuery = dbtSQLQuery' uid
in dbTableWidget' validator DBTable{..}

213
src/Handler/Sheet.hs
View File

@ -7,6 +7,7 @@ import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
import Handler.Utils.SheetType
import Handler.Utils.Delete
-- import Data.Time
-- import qualified Data.Text as T
@ -146,13 +147,17 @@ getSheetListR tid ssh csh = do
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
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
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
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
return (sheet, lastSheetEdit sheet, submission)
sheetFilter :: SheetName -> DB Bool
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
sheetCol = widgetColonnade . mconcat $
[ dbRow
, sortable (Just "name") (i18nCell MsgSheet)
@ -195,50 +200,59 @@ getSheetListR tid ssh csh = do
_other -> mempty
_other -> mempty
]
psValidator = def
& defaultSorting [("submission-since", SortAsc)]
table <- runDB $ dbTableWidget' psValidator DBTable
{ dbtSQLQuery = sheetData
, dbtColonnade = sheetCol
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
-> dbr <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
, dbtSorting = Map.fromList
[ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "last-edit"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
)
, ( "submission-since"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
)
, ( "submission-until"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
)
, ( "rating"
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
)
-- GitLab Issue $143: HOW TO SORT?
-- , ( "percent"
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
-- case sheetType of -- no Haskell inside Esqueleto, right?
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
-- )
]
, dbtFilter = Map.fromList
[]
, dbtStyle = def
, dbtIdent = "sheets" :: Text
}
-- Collect summary over all Sheets, not just the ones shown due to pagination:
statistics <- gradeSummaryWidget MsgSheetGradingSummaryTitle <$> do
rows <- runDB $ E.select $ E.from $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
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
return (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
return $ foldMap (\(E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) rows
& defaultSorting [SortDescBy "submission-since"]
(table,raw_statistics) <- runDB $ liftA2 (,)
(dbTableWidget' psValidator DBTable
{ dbtColonnade = sheetCol
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
-> dbr <$ guardM (lift $ sheetFilter sheetName)
, dbtSorting = Map.fromList
[ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "last-edit"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
)
, ( "submission-since"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
)
, ( "submission-until"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
)
, ( "rating"
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
)
-- GitLab Issue $143: HOW TO SORT?
-- , ( "percent"
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
-- case sheetType of -- no Haskell inside Esqueleto, right?
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
-- )
]
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "sheets" :: Text
}
) (
-- Collect summary over all Sheets, not just the ones shown due to pagination:
do
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
$(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
]
let psValidator = def
& defaultSorting [("type", SortAsc), ("path", SortAsc)]
& defaultSorting [SortAscBy "type", SortAscBy "path"]
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = fileData
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
, dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
, dbtStyle = def
, dbtFilter = Map.empty
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtIdent = "files" :: Text
, dbtSorting = Map.fromList
[ ( "type"
@ -307,6 +323,7 @@ getSShowR tid ssh csh shn = do
, SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileModified
)
]
, dbtParams = def
}
(hasHints, hasSolution) <- runDB $ do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
@ -467,20 +484,22 @@ handleSheetEdit tid ssh csh msId template dbAction = do
saveOkay <- runDB $ do
actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
let newSheet = Sheet
{ sheetCourse = cid
, sheetName = sfName
, sheetDescription = sfDescription
, sheetType = sfType
, sheetGrouping = sfGrouping
, sheetMarkingText = sfMarkingText
, sheetVisibleFrom = sfVisibleFrom
, sheetActiveFrom = sfActiveFrom
, sheetActiveTo = sfActiveTo
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
{ sheetCourse = cid
, sheetName = sfName
, sheetDescription = sfDescription
, sheetType = sfType
, sheetGrouping = sfGrouping
, sheetMarkingText = sfMarkingText
, sheetVisibleFrom = sfVisibleFrom
, sheetActiveFrom = sfActiveFrom
, sheetActiveTo = sfActiveTo
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
}
mbsid <- dbAction newSheet
case mbsid of
@ -512,30 +531,14 @@ handleSheetEdit tid ssh csh msId template dbAction = do
$(widgetFile "formPageI18n")
getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSDelR tid ssh csh shn = do
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
case result of
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
(FormSuccess BtnDelete) -> do
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
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSDelR = postSDelR
postSDelR tid ssh csh shn = do
sid <- runDB $ fetchSheetId tid ssh csh shn
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
}
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)
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
correctorForm shid = do
cListIdent <- newFormIdent
let
@ -608,7 +611,7 @@ correctorForm shid = do
let
currentLoads :: DB Loads
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
| Map.null currentLoads'
, 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
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
let
tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
@ -713,23 +717,25 @@ correctorForm shid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
return (corrResults, [ countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Nothing
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
-- Eingabebox für Korrektor hinzufü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
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess res' -> runDB $ do
FormSuccess (autoDistribute, res') -> runDB $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res'
addMessageI Success MsgCorrectorsUpdated

37
src/Handler/Submission.hs
View File

@ -4,9 +4,10 @@ import Import
import Jobs
-- import Yesod.Form.Bootstrap3
-- import Yesod.Form.Bootstrap3
import Handler.Utils
import Handler.Utils.Delete
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
@ -55,7 +56,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu
(Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
flip (renderAForm FormStandard) html $ (,)
<$> fileUploadForm
<*> ( (:|)
<*> ( (:|)
-- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students)
<$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
@ -66,7 +67,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu
<* submitButton
where
(groupNr, editableBuddies)
| Arbitrary{..} <- grouping = (maxParticipants, True)
| Arbitrary{..} <- grouping = (maxParticipants, True)
| RegisteredGroups <- grouping = (fromIntegral $ length buddies, False)
| otherwise = (0, False)
@ -140,7 +141,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
(Just smid) -> do
void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid
unless (shid == shid') $
invalidArgsI [MsgSubmissionWrongSheet]
@ -169,7 +170,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
mCID <- runDBJobs $ do
mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
res' <- case res of
FormMissing -> return FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs
@ -193,7 +194,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.&&. submission E.^. SubmissionSheet E.==. E.val shid
case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
Nothing -> return ()
Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
return $ E.countRows E.>. E.val (0 :: Int64)
return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
@ -252,7 +253,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return $ Just cID
(FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
_other -> return Nothing
case mCID of
Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return ()
@ -281,7 +282,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
in timeCell fileTime
]
coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))
coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
submissionFiles :: _ -> _ -> E.SqlQuery _
submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
@ -298,6 +299,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return ((sf1, f1), (sf2, f2))
smid2ArchiveTable (smid,cid) = DBTable
{ dbtSQLQuery = submissionFiles smid
, dbtRowKey = \((_ `E.InnerJoin` f1) `E.FullOuterJoin` (_ `E.InnerJoin` f2)) -> (f1 E.?. FileId, f2 E.?. FileId)
, dbtColonnade = colonnadeFiles cid
, dbtProj = return . dbrOutput
, 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)))
)
]
, dbtFilter = Map.empty
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtParams = def
}
mFileTable <- traverse (runDB . dbTableWidget' def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
@ -348,7 +352,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
whenM downloadFiles $
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
@ -358,13 +362,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
when (sfType == SubmissionCorrected) $
when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
| otherwise = ZIPArchiveName $ toPathPiece cID
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
respondSourceDB "application/zip" $ do
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
@ -387,3 +391,12 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
zipComment = Text.encodeUtf8 $ toPathPiece cID
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
}

56
src/Handler/SystemMessage.hs
View File

@ -13,6 +13,8 @@ import Handler.Utils
import Utils.Lens
import qualified Database.Esqueleto as E
htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' = htmlField
@ -57,7 +59,7 @@ postMessageR cID = do
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
)
<*> combinedButtonField (universeF :: [BtnSubmitDelete])
<*> combinedButtonFieldF ""
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
@ -154,7 +156,7 @@ postMessageListR = do
let
dbtSQLQuery = return
dbtColonnade = mconcat
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
[ dbSelect _2 id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow
, 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
@ -173,31 +175,47 @@ postMessageListR = do
{ dbrOutput = (smE, smT)
, ..
}
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- runDB $ dbTable psValidator DBTable
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (Last ActionSystemMessageData, DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
(tableRes', tableView) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = (E.^. SystemMessageId)
, dbtColonnade
, dbtProj
, dbtSorting = Map.fromList
[ -- TODO: from, to, authenticated, severity
]
, dbtFilter = Map.fromList
[
[ ( "from"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
)
, ( "to"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
)
, ( "authenticated"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
)
, ( "severity"
, SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
)
]
, dbtFilter = mempty
, dbtFilterUI = mempty
, 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
}
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
(fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
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)
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
return ((,) <$> actionRes <*> selectionRes, table <> action)
let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
& mapped._1 %~ fromMaybe (error "By construction the form should always return an action") . getLast
case tableRes of
FormMissing -> return ()

3
src/Handler/Term.hs
View File

@ -98,6 +98,7 @@ getTermShowR = do
-- ]
table <- runDB $ dbTableWidget' def DBTable
{ dbtSQLQuery = termData
, dbtRowKey = (E.^. TermId)
, dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput
, dbtSorting = Map.fromList
@ -126,7 +127,9 @@ getTermShowR = do
E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
)
]
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "terms" :: Text
}
defaultLayout $ do

47
src/Handler/Users.hs
View File

@ -9,18 +9,16 @@ import Utils.Lens
import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
hijackUserForm :: UserId -> Form UserId
hijackUserForm uid csrf = do
cID <- encrypt uid
hijackUserForm :: CryptoUUIDUser -> Form ()
hijackUserForm cID csrf = do
(uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
(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 = do
@ -59,18 +57,22 @@ getUsersR = do
<li>#{sh}
|]
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
cID <- encrypt uid
[whamlet|
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
^{hijackView}
|]
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
myUid <- liftHandlerT maybeAuthId
when (mayHijack && Just uid /= myUid) $ do
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
[whamlet|
<form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
^{hijackView}
|]
]
psValidator = def
& defaultSorting [("name", SortAsc),("display-name", SortAsc)]
& defaultSorting [SortAscBy "name", SortAscBy "display-name"]
((), userList) <- runDB $ dbTable psValidator DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtRowKey = (E.^. UserId)
, dbtColonnade
, dbtProj = return
, dbtSorting = Map.fromList
@ -85,7 +87,9 @@ getUsersR = do
)
]
, dbtFilter = mempty
, dbtFilterUI = mempty
, dbtStyle = def
, dbtParams = def
, dbtIdent = "users" :: Text
}
@ -96,21 +100,10 @@ getUsersR = do
postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
postAdminHijackUserR cID = do
uid <- decrypt cID
((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
((hijackRes, _), _) <- runFormPost $ hijackUserForm cID
case hijackRes of
FormSuccess uid'
| uid' == uid -> do
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"
ret <- formResultMaybe hijackRes $ \() -> Just <$> do
User{userIdent} <- runDB $ get404 uid
setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
get404 uid
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 ()
maybe (redirect UsersR) return ret

27
src/Handler/Utils/Course.hs Normal file
View 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
View 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

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

@ -23,8 +23,6 @@ import qualified Data.Text as T
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3
import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Handler.Utils.Zip
import qualified Data.Conduit.List as C
@ -37,6 +35,7 @@ import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Writer.Class
import Data.Scientific (Scientific)
@ -45,30 +44,33 @@ import Text.Read (readMaybe)
import Utils.Lens
import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText)
----------------------------
-- Buttons (new version ) --
----------------------------
data BtnDelete = BtnDelete | BtnAbort
data BtnDelete = BtnDelete
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece BtnDelete where -- for displaying the button only, not really for paths
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe BtnDelete
instance Finite BtnDelete
nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
instance Button UniWorX BtnDelete where
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
label BtnAbort = [whamlet|_{MsgBtnAbort}|]
cssClass BtnDelete = BCDanger
cssClass BtnAbort = BCDefault
data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece RegisterButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe RegisterButton
instance Finite RegisterButton
nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
instance Button UniWorX RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
@ -80,9 +82,10 @@ instance Button UniWorX RegisterButton where
data AdminHijackUserButton = BtnHijack
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece AdminHijackUserButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe AdminHijackUserButton
instance Finite AdminHijackUserButton
nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
instance Button UniWorX AdminHijackUserButton where
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
@ -102,7 +105,10 @@ instance Button UniWorX BtnSubmitDelete where
cssClass BtnSubmit' = BCPrimary
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.)
@ -312,7 +318,7 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
data SheetType' = Bonus' | Normal' | Informational' | NotGraded'
data SheetType' = Normal' | Bonus' | Informational' | NotGraded'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetType'
@ -353,8 +359,8 @@ sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler S
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
where
selOptions = Map.fromList
[ ( Bonus' , Bonus <$> gradingReq )
, ( Normal', Normal <$> gradingReq )
[ ( Normal', Normal <$> gradingReq )
, ( Bonus' , Bonus <$> gradingReq )
, ( Informational', Informational <$> gradingReq )
, ( 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 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.
( Finite k, Ord k

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

@ -1,13 +1,12 @@
module Handler.Utils.Sheet where
import Import
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, E.SqlSelect b a
, 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 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
&nbsp;<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"
}

27
src/Handler/Utils/SheetType.hs
View File

@ -9,25 +9,22 @@ import Utils.Lens
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
addBonusToPoints sts =
sts & _normalSummary . _achievedPoints %~ maxBonusPts . addBonusPts
& _normalSummary . _achievedPasses %~ maxBonusPass . addBonusPass
sts & _normalSummary . _achievedPasses %~ (min passmax . (passbonus +))
& _normalSummary . _achievedPoints %~ (min ptsmax . (ptsbonus +))
where
bonusPoints = sts ^. _bonusSummary . _achievedPoints
maxPoints = sts ^. _normalSummary . _sumGradePoints
maxBonusPts = fmap $ min maxPoints
addBonusPts = maybeAdd bonusPoints
passmax = sts ^. _normalSummary . _numMarkedPasses
passbonus = sts ^. _bonusSummary . _achievedPasses
ptsmax = sts ^. _normalSummary . _sumMarkedPoints
ptsbonus = sts ^. _bonusSummary . _achievedPoints
bonusPasses = sts ^. _bonusSummary . _achievedPasses
maxPasses = sts ^. _normalSummary . _numGradePasses
maxBonusPass = fmap $ min maxPasses
addBonusPass = maybeAdd bonusPasses
gradeSummaryWidget :: RenderMessage UniWorX msg => (Int -> msg) -> SheetTypeSummary -> Widget
gradeSummaryWidget :: RenderMessage UniWorX msg => (Integer -> msg) -> SheetTypeSummary -> Widget
gradeSummaryWidget title sts =
let SheetTypeSummary{..} = addBonusToPoints sts
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
hasPassings = positiveSum $ numGradePasses sumSummaries
hasPoints = positiveSum $ sumGradePoints sumSummaries
sumSummaries = normalSummary <> bonusSummary <> informationalSummary & _numSheets %~ (<> numNotGraded)
hasPasses = positiveSum $ numSheetsPasses sumSummaries
hasMarkedPasses = positiveSum $ numMarkedPasses sumSummaries
hasPoints = positiveSum $ numSheetsPoints sumSummaries
hasMarkedPoints = positiveSum $ numMarkedPoints sumSummaries
rowWdgts = [ $(widgetFile "widgets/gradingSummaryRow")
| (sumHeader,summary) <-
[ (MsgSheetTypeNormal' ,normalSummary)

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

@ -5,12 +5,14 @@ module Handler.Utils.Submission
, submissionFileSource, submissionFileQuery
, submissionMultiArchive
, SubmissionSinkException(..)
, msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB!
, sinkSubmission, sinkMultiSubmission
, submissionMatchesSheet
, submissionDeleteRoute
) where
import Import hiding (joinPath)
import Jobs
import Jobs.Queue
import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
@ -36,11 +38,10 @@ import Data.Ratio
import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Handler.Utils.Rating hiding (extractRatings)
import Handler.Utils
import qualified Handler.Utils.Rating as Rating (extractRatings)
import Handler.Utils.Zip
import Handler.Utils.Sheet
import Handler.Utils.Submission.TH
import Handler.Utils.Delete
import qualified Database.Esqueleto as E
@ -267,14 +268,6 @@ instance Monoid SubmissionSinkState where
mempty = memptydefault
mappend = mappenddefault
data SubmissionSinkException = DuplicateFileTitle FilePath
| DuplicateRating
| RatingWithoutUpdate
| ForeignRating CryptoFileNameSubmission
deriving (Typeable, Show)
instance Exception SubmissionSinkException
submissionBlacklist :: [Pattern]
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
@ -311,6 +304,18 @@ extractRatingsMsg = do
mr <- (toHtml . ) <$> getMessageRender
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
-> Either SheetId SubmissionId
-> Bool -- ^ Is this a correction
@ -510,15 +515,6 @@ sinkSubmission userId mExists isUpdate = do
-> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
| otherwise -> return ()
data SubmissionMultiSinkException
= SubmissionSinkException
{ _submissionSinkId :: CryptoFileNameSubmission
, _submissionSinkFedFile :: Maybe FilePath
, _submissionSinkException :: SubmissionSinkException
}
deriving (Typeable, Show)
instance Exception SubmissionMultiSinkException
sinkMultiSubmission :: UserId
-> Bool {-^ Are these corrections -}
@ -605,3 +601,40 @@ submissionMatchesSheet tid ssh csh shn cid = do
Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
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}
&nbsp;(_{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"
}

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

@ -1,15 +1,20 @@
{-# OPTIONS -fno-warn-orphans #-}
module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..)
( module Handler.Utils.Table.Pagination.Types
, SortColumn(..), SortDirection(..)
, pattern SortAscBy, pattern SortDescBy
, FilterColumn(..), IsFilterColumn
, DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
, DBStyle(..), DBEmptyStyle(..)
, DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..)
, DBParams(..)
, cellAttrs, cellContents
, PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..)
, defaultFilter, defaultSorting
, restrictFilter, restrictSorting
, ToSortable(..), Sortable(..), sortable
, ToSortable(..), Sortable(..)
, dbTable
, dbTableWidget, dbTableWidget'
, widgetColonnade, formColonnade, dbColonnade
@ -25,6 +30,7 @@ module Handler.Utils.Table.Pagination
) where
import Handler.Utils.Table.Pagination.Types
import Handler.Utils.Form
import Utils
import Utils.Lens.TH
@ -37,9 +43,6 @@ import qualified Data.Binary.Builder as Builder
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.Writer hiding ((<>), mapM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT)
@ -50,6 +53,10 @@ import Data.Foldable (Foldable(foldMap))
import Data.Map (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 qualified Colonnade (singleton)
import Colonnade.Encode
@ -60,22 +67,30 @@ import Data.Ratio ((%))
import Control.Lens
import Data.Aeson (Options(..), defaultOptions, decodeStrict')
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
import Data.Aeson.Text
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 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
toPathPiece SortAsc = "asc"
toPathPiece SortDesc = "desc"
fromPathPiece (CI.mk -> t)
| t == "asc" = Just SortAsc
| t == "desc" = Just SortDesc
| otherwise = Nothing
fromPathPiece = finiteFromPathPiece
deriveJSON defaultOptions
{ 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
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
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
| 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
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
{ psSorting :: [SortingSetting]
, psFilter :: Map FilterKey [Text]
, psLimit :: PagesizeLimit
, psPage :: Int64
}
@ -122,7 +208,7 @@ instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psLimit = PagesizeLimit 50
, psPage = 0
}
@ -131,9 +217,9 @@ deriveJSON defaultOptions
} ''PaginationSettings
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
{ piSorting :: Maybe [SortingSetting]
, piFilter :: Maybe (Map FilterKey [Text])
, piLimit :: Maybe PagesizeLimit
, piPage :: Maybe Int64
} deriving (Eq, Ord, Show, Read, Generic)
@ -186,36 +272,38 @@ instance Default (PSValidator m x) where
l <- asks piLimit
case l of
Just l'
Just (PagesizeLimit l')
| 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 ()
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'
where
injectDefault x = case x >>= piFilter of
Just _ -> id
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'
where
injectDefault x = case x >>= piSorting of
Just _ -> id
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
where
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
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
@ -228,6 +316,11 @@ data DBStyle = DBStyle
{ dbsEmptyStyle :: DBEmptyStyle
, dbsEmptyMessage :: UniWorXMessage
, dbsAttrs :: [(Text, Text)]
, dbsFilterLayout :: Widget -- ^ Filter UI
-> Enctype
-> Text -- ^ Filter action (target uri)
-> Widget -- ^ Table
-> Widget
}
instance Default DBStyle where
@ -235,24 +328,41 @@ instance Default DBStyle where
{ dbsEmptyStyle = def
, dbsEmptyMessage = MsgNoTableContent
, 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
, E.SqlSelect a r
, E.SqlSelect a r, SqlIn k k', ToJSON k', FromJSON k', Eq k'
, PathPiece i, Eq i
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
) => DBTable
{ dbtSQLQuery :: t -> E.SqlQuery a
, dbtRowKey :: t -> k
, dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
, dbtColonnade :: Colonnade h r' (DBCell m x)
, dbtSorting :: Map (CI Text) (SortColumn t)
, dbtFilter :: Map (CI Text) (FilterColumn t)
, dbtSorting :: Map SortingKey (SortColumn t)
, dbtFilter :: Map FilterKey (FilterColumn t)
, dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (ReaderT SqlBackend (HandlerT UniWorX IO)) (Map FilterKey [Text])
, dbtStyle :: DBStyle
, dbtParams :: DBParams m x
, 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 :: *
@ -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)
-- | 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
dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> PaginationInput -> (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)
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' 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 = dbCell . _1
@ -273,6 +383,7 @@ cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
data DBParams (HandlerT UniWorX IO) x = DBParamsWidget
type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = ()
@ -288,13 +399,17 @@ instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
runDBTable = liftHandlerT
runDBTable _ _ _ = liftHandlerT
instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty $ return mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
instance Default (DBParams (HandlerT UniWorX IO) x) where
def = DBParamsWidget
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)
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
dbHandler _ _ f = return . over _2 f
-- 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
mempty = DBCell mempty $ return mempty
(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
-- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
data DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = DBParamsForm
{ 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)
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))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget dbtable pi = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . addPIHiddenField dbtable pi
dbHandler dbtable pi f form = return $ fmap (over _2 f) . addPIHiddenField dbtable pi form
dbWidget _ _ = return . snd
dbHandler _ _ f = return . over _2 f
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- 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 = 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
addPIHiddenField DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } pi form fragment = form $ fragment <> [shamlet|
<input type=hidden name=#{wIdent "pagination"} value=#{encodeToTextBuilder pi}>
instance Monoid a => Default (DBParams (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
def = DBParamsForm
{ 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
wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
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
let
sortingOptions = mkOptionList
[ Option t' (t, d) t'
[ Option t' (SortingSetting t d) t'
| (t, _) <- mapToList dbtSorting
, d <- [SortAsc, SortDesc]
, let t' = CI.foldedCase t <> "-" <> toPathPiece d
, let t' = toPathPiece $ SortingSetting t d
]
wIdent n
| not $ null dbtIdent = dbtIdent <> "-" <> n
| otherwise = n
wIdent :: Text -> Text
wIdent = toPathPiece . WithIdent dbtIdent
dbsAttrs'
| not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
| otherwise = dbsAttrs
@ -379,62 +550,120 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
, 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")
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
<*> iopt intField (wIdent "pagesize")
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter)
<*> iopt pathPieceField (wIdent "pagesize")
<*> 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
let
(errs, PaginationSettings{..}) = case piPrevious <|> piResult of
(errs, PaginationSettings{..}) = case piResult of
FormSuccess pi
| not (piIsUnset pi)
-> runPSValidator dbtable $ Just pi
FormFailure errs'
-> first (map SomeMessage errs' <>) $ runPSValidator dbtable Nothing
_ -> runPSValidator dbtable Nothing
paginationInput
| FormSuccess pi <- piPrevious <|> piResult
paginationInput@PaginationInput{..}
| FormSuccess pi <- piResult
, not $ piIsUnset pi
= pi
| otherwise
= def
psSorting' = map (first (dbtSorting !)) psSorting
psSorting' = map (\SortingSetting{..} -> (dbtSorting ! sortKey, sortDir)) psSorting
mapM_ (addMessageI Warning) errs
rows' <- E.select . E.from $ \t -> do
res <- dbtSQLQuery t
E.orderBy (map (sqlSortDirection t) psSorting')
E.limit psLimit
E.offset (psPage * psLimit)
case previousKeys of
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
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
rowCount
| (E.Value n, _):_ <- rows' = n
| (E.Value n, _, _):_ <- rows' = n
| 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' = do
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
let
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- sortableContent ^. cellContents
let
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
directions = [dir | SortingSetting k dir <- psSorting, Just k == sortableKey ]
isSortable = isJust sortableKey
isSorted = (`elem` directions)
attrs = sortableContent ^. cellAttrs
@ -451,20 +680,27 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
return $(widgetFile "table/cell/body")
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]
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
tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
tblLayout tbl' = do
tbl <- liftHandlerT $ widgetToPageContent tbl'
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 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
-> 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)
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
@ -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 initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
formCell :: forall r i a. Ord i
=> (r -> MForm (HandlerT UniWorX IO) i)
formCell :: forall res r i a. (Ord i, Monoid res)
=> Lens' res (DBFormResult r i a)
-> (r -> MForm (HandlerT UniWorX IO) i)
-> (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)))
formCell genIndex genForm input = FormCell
-> (r -> DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
formCell resLens genIndex genForm input = FormCell
{ formCellAttrs = []
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
i <- genIndex input
(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 = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
=> Setter' a Bool
dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
=> Lens' res (DBFormResult r i a)
-> Setter' a Bool
-> (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)))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
-> Colonnade h r (DBCell (MForm (HandlerT UniWorX IO)) (FormResult res))
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)
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
return (set selLens <$> selResult, [whamlet|^{fvInput selWidget}|])

66
src/Handler/Utils/Table/Pagination/Types.hs
View File

@ -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)
@ -7,12 +17,30 @@ import Colonnade.Encode
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
{ sortableKey :: Maybe (CI Text)
{ sortableKey :: Maybe SortingKey
, 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)
instance Headedness Sortable where
@ -36,3 +64,35 @@ instance ToSortable Headed where
instance ToSortable Headless where
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)|]
]
) []
]
]

6
src/Import/NoFoundation.hs
View File

@ -8,6 +8,7 @@ import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
import Model.Rating as Import
import Model.Submission as Import
import Settings as Import
import Settings.StaticFiles 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 Utils as Import
import Yesod.Core.Json as Import (provideJson)
import Yesod.Core.Types.Instances 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.Text.Encoding.Error as Import(UnicodeException(..))
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(..))
@ -49,6 +53,8 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Network.Mail.Mime.Instances as Import ()
import Yesod.Core.Instances as Import ()
import Ldap.Client.Pool as Import
import Control.Monad.Trans.RWS (RWST)

1
src/Jobs.hs
View File

@ -57,6 +57,7 @@ import Jobs.Handler.SendTestEmail
import Jobs.Handler.QueueNotification
import Jobs.Handler.HelpRequest
import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
data JobQueueException = JInvalid QueuedJobId QueuedJob

9
src/Jobs/Crontab.hs
View File

@ -71,6 +71,15 @@ determineCrontab = execWriterT $ do
, cronRateLimit = appNotificationRateLimit
, 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 <$>
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []

21
src/Jobs/Handler/DistributeCorrections.hs Normal file
View 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

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

@ -22,26 +22,37 @@ dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
determineNotificationCandidates :: Notification -> DB [Entity User]
determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
return user
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..} = 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
determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] []
determineNotificationCandidates NotificationSubmissionRated{..}
= E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
return user
determineNotificationCandidates NotificationSheetActive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..}
= E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..}
= 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
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 NotificationSubmissionRated{..} = do
@ -53,5 +64,6 @@ classifyNotification NotificationSheetActive{} = return NTSheetActive
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed

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

@ -11,6 +11,7 @@ import Jobs.Handler.SendNotification.SubmissionRated
import Jobs.Handler.SendNotification.SheetActive
import Jobs.Handler.SendNotification.SheetInactive
import Jobs.Handler.SendNotification.CorrectionsAssigned
import Jobs.Handler.SendNotification.CorrectionsNotDistributed
dispatchJobSendNotification :: UserId -> Notification -> Handler ()

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

@ -22,7 +22,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
setSubjectI $ MsgMailSubjectCorrectionsAssigned courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm

31
src/Jobs/Handler/SendNotification/CorrectionsNotDistributed.hs Normal file
View File

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

1
src/Jobs/Queue.hs
View File

@ -3,6 +3,7 @@ module Jobs.Queue
, queueJob, queueJob'
, YesodJobDB
, runDBJobs, queueDBJob
, module Jobs.Types
) where
import Import

2
src/Jobs/Types.hs
View File

@ -19,12 +19,14 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
| NotificationSheetSoonInactive { nSheet :: SheetId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job

100
src/Ldap/Client/Pool.hs Normal file
View 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

5
src/Model.hs
View File

@ -8,9 +8,10 @@ module Model
import ClassyPrelude.Yesod
import Database.Persist.Quasi
import Database.Persist.TH.Directory
-- import Data.Time
-- import Data.ByteString
import Model.Types
import Model.Types hiding (_maxPoints, _passingPoints)
import Cron.Types
import Data.Aeson (Value)
@ -26,7 +27,7 @@ import Settings.Cluster (ClusterSettingsKey)
-- at:
-- http://www.yesodweb.com/book/persistent/
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
deriving instance Eq (Unique Course)

22
src/Model/Submission.hs Normal file
View 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

80
src/Model/Types.hs
View File

@ -77,6 +77,8 @@ import Data.Data (Data)
import Model.Types.Wordlist
import Data.Text.Metrics (damerauLevenshtein)
import qualified Database.Esqueleto as E
instance PathPiece UUID where
fromPathPiece = UUID.fromString . unpack
toPathPiece = pack . UUID.toString
@ -100,8 +102,14 @@ instance ToHttpApiData (CI Text) where
instance FromHttpApiData (CI Text) where
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
toPoints :: Integral a => a -> Points -- deprecated
@ -115,6 +123,8 @@ fromPoints = round
instance DisplayAble Points
instance DisplayAble a => DisplayAble (Sum a) where
display (Sum x) = display x
data SheetGrading
= Points { maxPoints :: Points }
@ -129,17 +139,35 @@ deriveJSON defaultOptions
} ''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 (Points {}) _ = Nothing
gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
gradingPassed (PassBinary {}) pts = Just $ pts /= 0
gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
where pBinary _ = pts /= 0
pPoints b = pts >= b
data SheetGradeSummary = SheetGradeSummary
{ numSheets :: Sum Int
, numGradePasses :: Sum Int
, sumGradePoints :: Sum Points
, achievedPasses :: Maybe (Sum Int)
, achievedPoints :: Maybe (Sum Points)
{ numSheets :: Count -- Total number of sheets, includes all
, numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses
, numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd
, sumSheetsPoints :: Sum Points -- Total of all points in all sheets
-- 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)
instance Monoid SheetGradeSummary where
@ -152,20 +180,23 @@ instance Semigroup SheetGradeSummary where
makeLenses_ ''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) =
let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p }
in case gr of PassBinary -> baseSum
_other -> baseSum { achievedPoints = Just $ Sum $ p }
sheetGradeSum (Points {..}) Nothing = mempty { numSheets = Sum 1
, sumGradePoints = Sum maxPoints
}
sheetGradeSum (PassPoints{..}) Nothing = mempty { numSheets = Sum 1
, numGradePasses = Sum 1
, sumGradePoints = Sum maxPoints
}
sheetGradeSum (PassBinary) Nothing = mempty { numSheets = Sum 1
, numGradePasses = Sum 1
}
let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
in unmarked
{ numMarked = numSheets
, numMarkedPasses = numSheetsPasses
, numMarkedPoints = numSheetsPoints
, sumMarkedPoints = sumSheetsPoints
, achievedPasses = fromMaybe mempty $ bool 0 1 <$> gradingPassed gr p
, achievedPoints = bool mempty (Sum p) $ has _maxPoints gr
}
data SheetType
= Normal { grading :: SheetGrading }
@ -185,7 +216,7 @@ data SheetTypeSummary = SheetTypeSummary
{ normalSummary
, bonusSummary
, informationalSummary :: SheetGradeSummary
, numNotGraded :: Sum Int
, numNotGraded :: Count
} deriving (Generic, Read, Show, Eq)
instance Monoid SheetTypeSummary where
@ -543,6 +574,7 @@ data NotificationTrigger = NTSubmissionRatedGraded
| NTSheetSoonInactive
| NTSheetInactive
| NTCorrectionsAssigned
| NTCorrectionsNotDistributed
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe NotificationTrigger
@ -573,6 +605,7 @@ instance Default NotificationSettings where
NTSheetSoonInactive -> False
NTSheetInactive -> True
NTCorrectionsAssigned -> True
NTCorrectionsNotDistributed -> True
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
@ -680,7 +713,7 @@ _PseudonymText = prism' tToWords tFromWords . _PseudonymWords
pseudonymWords :: Fold Text PseudonymWord
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
distance = damerauLevenshtein `on` CI.foldedCase
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
@ -694,6 +727,7 @@ pseudonymFragments = folding
data AuthTag
= AuthFree
| AuthAdmin
| AuthNoEscalation
| AuthDeprecated
| AuthDevelopment
| AuthLecturer

10
src/Network/Mail/Mime/Instances.hs
View File

@ -12,6 +12,8 @@ import Data.Aeson
import Data.Aeson.TH
import Utils.PathPiece
import Utils (assertM)
deriving instance Read Address
@ -20,6 +22,12 @@ deriving instance Generic Address
instance Hashable Address
deriveJSON defaultOptions
deriveToJSON defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
} ''Address
instance FromJSON Address where
parseJSON = withObject "Address" $ \obj -> do
addressName <- assertM (not . null) <$> (obj .:? "name")
addressEmail <- obj .: "email"
return Address{..}

16
src/Settings.hs
View File

@ -59,11 +59,15 @@ import qualified Database.Memcached.Binary.Types as Memcached
import Model
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
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
data AppSettings = AppSettings
{ appStaticDir :: String
{ appStaticDir :: FilePath
-- ^ Directory from which to serve static files.
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
@ -162,6 +166,7 @@ data LdapConf = LdapConf
, ldapBase :: Ldap.Dn
, ldapScope :: Ldap.Scope
, ldapTimeout :: Int32
, ldapPool :: ResourcePoolConf
} deriving (Show)
data SmtpConf = SmtpConf
@ -248,6 +253,7 @@ instance FromJSON LdapConf where
ldapBase <- Ldap.Dn <$> o .: "baseDN"
ldapScope <- o .: "scope"
ldapTimeout <- o .: "timeout"
ldapPool <- o .: "pool"
return LdapConf{..}
deriveFromJSON
@ -358,7 +364,13 @@ instance FromJSON AppSettings where
appUserDefaults <- o .: "user-defaults"
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 {..}

28
src/Utils.hs
View File

@ -337,7 +337,7 @@ ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argu
ifMaybeM Nothing dft _ = return dft
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
| otherwise = Nothing
@ -371,6 +371,9 @@ instance Ord a => Ord (NTop (Maybe a)) where
compare _ (NTop Nothing) = LT
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 --
@ -445,6 +448,9 @@ guardM f = guard =<< f
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
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' f x = x <$ guard (f x)
@ -492,6 +498,12 @@ partitionM crit = ofoldlM dist mempty
| okay -> acc `mappend` (opoint x, mempty)
| 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 --
@ -530,6 +542,20 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
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 --
---------------------------------

176
src/Utils/Form.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-deprecations #-}
module Utils.Form where
import ClassyPrelude.Yesod hiding (addMessage)
import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..))
import Settings
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.Set as Set
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.List ((!!))
import Control.Lens
import Web.PathPieces
import Data.UUID
import Utils.Message
import Utils.PathPiece
import Data.Proxy
-------------------
-- Form Renderer --
-------------------
-- | 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 formLayout aform fragment = do
(res, ($ []) -> views) <- aFormToForm aform
(res, ($ []) -> fieldViews) <- aFormToForm aform
let widget = $(widgetFile "widgets/form")
return (res, widget)
@ -144,6 +153,9 @@ inputDisabled = addAttr "disabled" ""
inputReadonly :: FieldSettings site -> FieldSettings site
inputReadonly = addAttr "readonly" ""
addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "data-autosubmit" ""
------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------
@ -163,6 +175,9 @@ data FormIdentifier
| FIDSystemMessageModify
| FIDSystemMessageModifyTranslation UUID
| FIDSystemMessageAddTranslation
| FIDDBTableFilter
| FIDDBTablePagesize
| FIDDelete
deriving (Eq, Ord, Read, Show)
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 = toWidget . toPathPiece
btnValidate :: forall p. p site -> a -> Bool
btnValidate _ _ = True
cssClass :: a -> ButtonCssClass site
data ButtonMessage = MsgAmbiguousButtons
| MsgWrongButtonValue
| MsgMultipleButtonValues
data SubmitButton = BtnSubmit
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance PathPiece SubmitButton where
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
instance Universe SubmitButton
instance Finite SubmitButton
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)
buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
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
fieldEnctype = UrlEncoded
fieldView :: FieldViewFunc m a
fieldView fid name attrs _val _ = let
cssClass' :: ButtonCssClass site
cssClass' :: ButtonCssClass (HandlerSite m)
cssClass' = cssClass btn
validate = btnValidate (Proxy @(HandlerSite m)) btn
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 [str] _
| str == toPathPiece btn = return $ Right $ Just btn
| otherwise = return $ Left "Wrong button value"
fieldParse _ _ = return $ Left "Multiple button values"
fieldParse [] [] = return $ Right Nothing
fieldParse [str] []
| str == toPathPiece btn = return . Right $ Just btn
| otherwise = return . Left $ SomeMessage MsgWrongButtonValue
fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
combinedButtonField = traverse b2f
where
b2f b = aopt (buttonField b) "" Nothing
combinedButtonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, 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) ()
submitButton = void $ combinedButtonField [BtnSubmit]
combinedButtonFieldF :: forall m a.
( 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 --
@ -240,6 +329,12 @@ ciField :: ( Textual t
) => Field m (CI t)
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
, HandlerSite m ~ site
, Eq a
@ -295,6 +390,27 @@ optionsFinite = do
-- 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 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 FormMissing _ = return Nothing
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
View 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

2
stack.nix
View File

@ -7,7 +7,7 @@ in haskell.lib.buildStackProject {
inherit ghc;
name = "stackenv";
buildInputs = (with pkgs;
[ postgresql zlib openldap cyrus_sasl.dev libsodium
[ postgresql zlib libsodium
]) ++ (with haskellPackages;
[ yesod-bin
]);

2
stack.yaml
View File

@ -29,7 +29,7 @@ extra-deps:
- uuid-crypto-1.4.0.0
- filepath-crypto-0.1.0.0
- cryptoids-0.5.1.0
- cryptoids-types-0.0.0
- cryptoids-types-1.0.0
- cryptoids-class-0.0.0
- system-locale-0.3.0.0

5
templates/corrections-grade.hamlet
View File

@ -1,5 +1,2 @@
<div .container>
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
^{table}
<button type=submit>
_{MsgBtnSubmit}
^{table}

7
templates/corrections.hamlet
View File

@ -1,7 +1,4 @@
<section>
<form method=POST enctype=#{tableEncoding} action=@{currentRoute}>
^{table}
<button type=submit>
_{MsgBtnSubmit}
^{table}
<section>
^{statistics}
^{statistics}

13
templates/default-layout.lucius
View File

@ -439,6 +439,19 @@ input[type="button"].btn-info:hover,
}
.list--inline {
ul {
display: inline-block;
margin-left: 0;
li {
display: inline-block;
}
}
}
ul.list--inline {
display: inline-block;
margin-left: 0;
li {

17
templates/mail/correctionsUndistributed.hamlet Normal file
View 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}

1
templates/standalone/inputs.lucius
View File

@ -65,6 +65,7 @@
/* TEXT INPUTS */
input[type="text"],
input[type="search"],
input[type="password"],
input[type="url"],
input[type="number"],

5
templates/system-message-list.hamlet
View File

@ -1,8 +1,5 @@
<section>
<form method=post action=@{MessageListR} encytpe=#{tableEncoding}>
^{tableView}
<button type=submit>
_{MsgBtnSubmit}
^{tableView}
<section>
<form method=post action=@{MessageListR} enctype=#{addEncoding}>

4
templates/table/cell/header.hamlet
View File

@ -2,10 +2,10 @@
$maybe flag <- sortableKey
$case directions
$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}
$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}
$nothing
^{widget}

5
templates/table/form-wrap.hamlet Normal file
View 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
View File

@ -0,0 +1,6 @@
$newline never
<section>
<form method=GET action=#{filterAction} enctype=#{filterEnctype}>
^{filterWgdt}
<section>
^{scrolltable}

13
templates/table/layout.hamlet
View File

@ -5,8 +5,11 @@ $else
<div .scrolltable>
^{table}
$if pageCount > 1
<ul ##{wIdent "pagination"} .pagination>
$forall p <- pageNumbers
<li .pagination-link :p == psPage:.current>
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
_{MsgPage (succ p)}
<div .pagination>
<form .pagesize method=GET enctype=#{pagesizeEnc} action=#{rawAction}>
^{pagesizeWdgt}
<ul ##{wIdent "pagination"} .pages>
$forall p <- pageNumbers
<li .page-link :p == psPage:.current>
<a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
_{MsgPage (succ p)}

12
templates/table/layout.julius
View File

@ -10,19 +10,19 @@
function setupAsync(wrapper) {
var table = wrapper.querySelector('#' + #{String $ dbtIdent});
var table = wrapper.querySelector('#' + #{String dbtIdent});
if (!table)
return;
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) {
th.addEventListener('click', clickHandler);
});
if (pagination) {
Array.from(pagination.querySelectorAll('.pagination-link'))
Array.from(pagination.querySelectorAll('.page-link'))
.forEach(function(p) {
p.addEventListener('click', clickHandler);
});
@ -32,12 +32,6 @@
event.preventDefault();
var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
updateTableFrom(url);
ths.forEach(function(th) {
// th.removeEventListener('click', clickHandler);
console.log('removed handler from', th);
});
}
function getClickDestination(el) {

74
templates/table/layout.lucius
View File

@ -1,39 +1,51 @@
/* PAGINATION */
.pagination {
margin-top: 20px;
text-align: center;
margin-top: 20px;
display: flex;
flex-direction: row;
.pagination-link {
margin: 0 7px;
display: inline-block;
background-color: var(--color-grey);
a {
color: var(--color-lightwhite);
padding: 7px 13px;
display: inline-block;
.pagesize {
float: left;
flex-grow: 0;
}
&:not(.current):hover {
background-color: var(--color-lighter);
.pages {
text-align: center;
flex-grow: 1;
margin: 0;
a {
color: var(--color-lightwhite);
}
.page-link {
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
View 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
View File

@ -0,0 +1,5 @@
.confirmationText {
white-space: pre-wrap;
font-size: 14px;
font-family: monospace;
}

7
templates/widgets/form.hamlet
View File

@ -1,8 +1,11 @@
$newline never
#{fragment}
$case formLayout
$of FormStandard
$forall view <- views
$of FormDBTablePagesize
$forall view <- fieldViews
^{fvInput view}
$of _
$forall view <- fieldViews
$# 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>
$if not (Blaze.null $ fvLabel view)

25
templates/widgets/form.julius
View File

@ -77,7 +77,7 @@ document.addEventListener('setup', function(e) {
var forms = e.detail.scope.querySelectorAll('form');
Array.from(forms).forEach(function(form) {
// 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) {
window.utils.reactiveButton(form, submitBtn, validateForm);
});
@ -102,3 +102,26 @@ document.addEventListener('setup', function(e) {
document.addEventListener('DOMContentLoaded', function() {
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 }))
});

5
templates/widgets/form.lucius
View File

@ -17,3 +17,8 @@ fieldset {
opacity: 0;
margin: 0;
}
.select--pagesize {
width: 5em;
min-width: 75px;
}

32
templates/widgets/gradingSummary.hamlet
View File

@ -1,15 +1,25 @@
$# 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>
<h3>_{title $ getSum $ numSheets $ sumSummaries}
<h3>_{MsgSummaryTitle} _{title $ getSum $ numSheets $ sumSummaries}
<table .table .table--striped>
<tr .table__row .table__row--head>
<th>
$# empty cell for row headers
$maybe _ <- hasPassings
<th .table__th colspan=2>_{MsgSheetGradingPassing'}
$# empty cell for row headers
$maybe _ <- hasMarkedPasses
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPasses
<th .table__th>_{MsgSheetGradingPassing'}
$maybe _ <- hasMarkedPoints
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPoints
<th .table__th colspan=2>_{MsgSheetGradingPoints'}
<th .table__th>_{MsgSheetGradingPoints'}
<th .table__th>_{MsgSheetGradingCount'}
$# Number of Sheet/Submissions used for calculating maximum passes/points
$forall row <- rowWdgts
@ -17,14 +27,18 @@ $# --
$maybe nrNoGrade <- positiveSum $ numNotGraded
<tr .table__row>
<th .table__th>_{MsgSheetTypeNotGraded}
$maybe _ <- hasPassings
$maybe _ <- hasMarkedPasses
<td colspan=2>
$maybe _ <- hasPoints
$maybe _ <- hasPasses
<td .table__td>
$maybe _ <- hasMarkedPoints
<td .table__td colspan=2>
$maybe _ <- hasPoints
<td .table__td>
<td .table__td>#{display nrNoGrade}
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
<p>_{MsgSheetTypeInfoBonus}
$maybe _ <- positiveSum =<< (bonusSummary ^. _achievedPoints)
<p>_{MsgSheetTypeInfoBonus} #
$maybe _ <- positiveSum $ bonusSummary ^. _achievedPoints
_{MsgSheetGradingBonusIncluded}
$maybe _ <- positiveSum $ informationalSummary ^. _numSheets
<p>_{MsgSheetTypeInfoNotGraded}

65
templates/widgets/gradingSummaryRow.hamlet
View File

@ -1,33 +1,54 @@
$# Displays one row of the grading summary
$# Expects several variables:
$# hasPassing :: Maybe Int -- Should Passing be displayed?
$# hasPoints :: Maybe Poibts -- Should Points be displayed?
$# summary :: SheetGradeSummary -- summary to display
$# 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
<tr .table__row >
$# TODO: Durschnittliche Punktzahl anzeigen
$# TODO: Extra-Spalte für Punkte Bewertet = numMarkedPoints / Punkte Gesamt = sumSheetPoints
$#
$maybe _ <- positiveSum $ summary ^. _numSheets
<tr .table__row>
<th .table__th>_{sumHeader}
$maybe _ <- hasPassings
$with Sum pmax <- summary ^. _numGradePasses
$maybe Sum pacv <- summary ^. _achievedPasses
$maybe _ <- hasMarkedPasses
$with Sum pmax <- summary ^. _numMarkedPasses
$if pmax > 0
$with Sum pacv <- summary ^. _achievedPasses
<td .table__td>
$if pmax /= 0
$if pmax > 0
#{textPercentInt pacv pmax}
<td .table__td>
#{display pacv} / #{display pmax}
$nothing
<td .table__td colspan=2>
#{display pmax }
$else
<td .table__td>
<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
$with Sum pmax <- summary ^. _sumGradePoints
$maybe Sum pacv <- summary ^. _achievedPoints
<td .table__td>
$if pmax /= 0
#{textPercent $ realToFrac $ pacv / pmax}
<td .table__td>
#{display pacv} / #{display pmax}
$nothing
<td .table__td colspan=2>
#{display pmax }
<td .table__td>#{display nrSheets}
<td .table__td>
#{display (summary ^. _sumSheetsPoints)}
$if ((summary ^. _numSheetsPoints) /= (summary ^. _numSheets))
$# Falls Anzahl Blätter der Zeile verschieden von Anzahl Blätter mit Punkten
\ (_{title $ getSum $ summary ^. _numSheetsPoints})
$# Kurze Alternative mit Hashtag-Symbol für "Anzahl"
$# \ (##{display $ summary ^. _numSheetsPoints})
<td .table__td>#{display $ summary ^. _numSheets}

41
templates/widgets/sheetTypeSummary.hamlet
View File

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

7
test/Database.hs
View File

@ -237,11 +237,11 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost 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
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
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
-- EIP
eip <- insert' Course
@ -330,6 +330,7 @@ fillDb = do
, sheetUploadMode = Upload True
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
, sheetAutoDistribute = True
}
void . insert $ SheetEdit jost now sh1
forM_ [fhamann, maxMuster, tinaTester] $ \u -> do