diff --git a/README.md b/README.md deleted file mode 100644 index 2d59db31a..000000000 --- a/README.md +++ /dev/null @@ -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 diff --git a/config/keter_testworx.yml b/config/keter_testworx.yml index be7037613..6ec58b7ba 100644 --- a/config/keter_testworx.yml +++ b/config/keter_testworx.yml @@ -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 diff --git a/config/keter_uni2work.yml b/config/keter_uni2work.yml index 873124070..f3fa11860 100644 --- a/config/keter_uni2work.yml +++ b/config/keter_uni2work.yml @@ -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 diff --git a/config/settings.yml b/config/settings.yml index 2ff396932..e681e8e27 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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:" diff --git a/messages/button/de.msg b/messages/button/de.msg new file mode 100644 index 000000000..de25fb0c6 --- /dev/null +++ b/messages/button/de.msg @@ -0,0 +1,3 @@ +AmbiguousButtons: Mehrere Submit-Buttons aktiv +WrongButtonValue: Submit-Button hat falschen Wert +MultipleButtonValues: Submit-Button hat mehrere Werte \ No newline at end of file diff --git a/messages/dummy/de.msg b/messages/dummy/de.msg index f3ca7cae1..5a24922aa 100644 --- a/messages/dummy/de.msg +++ b/messages/dummy/de.msg @@ -1 +1,2 @@ -DummyIdent: Nutzer-Kennung \ No newline at end of file +DummyIdent: Nutzer-Kennung +DummyNoFormData: Keine Formulardaten empfangen \ No newline at end of file diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1595dc8d9..5521a602e 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 \ No newline at end of file +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. \ No newline at end of file diff --git a/models b/models deleted file mode 100644 index 47e95f579..000000000 --- a/models +++ /dev/null @@ -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 \ No newline at end of file diff --git a/models/config b/models/config new file mode 100644 index 000000000..33bcaf8d6 --- /dev/null +++ b/models/config @@ -0,0 +1,4 @@ +ClusterConfig + setting ClusterSettingsKey + value Value + Primary setting \ No newline at end of file diff --git a/models/courses b/models/courses new file mode 100644 index 000000000..9ecc31abe --- /dev/null +++ b/models/courses @@ -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 diff --git a/models/exams b/models/exams new file mode 100644 index 000000000..e356e4221 --- /dev/null +++ b/models/exams @@ -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) \ No newline at end of file diff --git a/models/files b/models/files new file mode 100644 index 000000000..62a5ffe72 --- /dev/null +++ b/models/files @@ -0,0 +1,5 @@ +File + title FilePath + content ByteString Maybe -- Nothing iff this is a directory + modified UTCTime + deriving Show Eq Generic diff --git a/models/jobs b/models/jobs new file mode 100644 index 000000000..15f7bb7dc --- /dev/null +++ b/models/jobs @@ -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 diff --git a/models/rooms b/models/rooms new file mode 100644 index 000000000..7b62d41f5 --- /dev/null +++ b/models/rooms @@ -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 ... diff --git a/models/schools b/models/schools new file mode 100644 index 000000000..b253c7390 --- /dev/null +++ b/models/schools @@ -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 diff --git a/models/sheets b/models/sheets new file mode 100644 index 000000000..207f22ee0 --- /dev/null +++ b/models/sheets @@ -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 diff --git a/models/submissions b/models/submissions new file mode 100644 index 000000000..db7e543a6 --- /dev/null +++ b/models/submissions @@ -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 diff --git a/models/system-messages b/models/system-messages new file mode 100644 index 000000000..0547718ae --- /dev/null +++ b/models/system-messages @@ -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 diff --git a/models/terms b/models/terms new file mode 100644 index 000000000..ba6cafd73 --- /dev/null +++ b/models/terms @@ -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 diff --git a/models/tutorials b/models/tutorials new file mode 100644 index 000000000..51e20b195 --- /dev/null +++ b/models/tutorials @@ -0,0 +1,8 @@ +Tutorial json + name Text + tutor UserId + course CourseId +TutorialUser + user UserId + tutorial TutorialId + UniqueTutorialUser user tutorial diff --git a/models/users b/models/users new file mode 100644 index 000000000..0cd2d682a --- /dev/null +++ b/models/users @@ -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 diff --git a/package.yaml b/package.yaml index 4bc841965..1bd402afd 100644 --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/routes b/routes index 4508cb781..f29cc077b 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Application.hs b/src/Application.hs index cdf4d9ecc..144945e00 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index df4ab5e40..bb26aa344 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 2b053ce05..0eebdd5f3 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index 3efad0d32..53001ce92 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 2331dbfc3..58fa1a09a 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -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) diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index 7dc9123e8..bfc2790ff 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -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 diff --git a/src/Data/Monoid/Instances.hs b/src/Data/Monoid/Instances.hs new file mode 100644 index 000000000..44909d53f --- /dev/null +++ b/src/Data/Monoid/Instances.hs @@ -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) diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs new file mode 100644 index 000000000..770b71d71 --- /dev/null +++ b/src/Database/Persist/TH/Directory.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 601db3527..7d5aef0cd 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 ] diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 803ef4bae..794d88071 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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 () diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e843ade32..e8cae3a63 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index f4125de79..8a259bb02 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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 diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index dab2a6b83..0058fee8e 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -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{..} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 6728e11a2..c938932d6 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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||] - 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| -
- ^{fvInput addTutView} -