diff --git a/CHANGELOG.md b/CHANGELOG.md index e1e07c871..ce0147d38 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,104 @@ All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines. +## [4.2.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.1.2...v4.2.0) (2019-07-23) + + +### Bug Fixes + +* **exam registration:** icons added to exam register message ([ce61528](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ce61528)) +* **exams:** change heading to rooms if no occurrence times are shown ([5cb9404](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/5cb9404)) +* fix build ([caf4092](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/caf4092)) + + +### Features + +* **csv:** finish implementing csv import ([e35fed6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e35fed6)) +* **csv:** implement csv import ([996bc2a](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/996bc2a)) +* **exams:** allow assigning exam participants to occurrences ([e1996ac](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e1996ac)) + + + +### [4.1.2](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.1.1...v4.1.2) (2019-07-17) + + +### Bug Fixes + +* **corrections:** properly link corrector emails ([9385595](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9385595)) + + + +### [4.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.1.0...v4.1.1) (2019-07-17) + + +### Bug Fixes + +* **aform:** show info about required fields in all aforms ([63f6d01](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/63f6d01)), closes [#418](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/418) +* **submissions:** only notify submittors if rating changes doneness ([4f1162c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/4f1162c)) +* **submissions:** only notify submittors if rating is done ([8e0c379](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8e0c379)) +* **submissions:** submitting produces an success alert now ([bf20d6f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/bf20d6f)), closes [#286](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/286) + + + +## [4.1.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.0.1...v4.1.0) (2019-07-17) + + +### Features + +* **exams:** allow forced deregistration ([1b532c4](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/1b532c4)) + + + +### [4.0.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.0.0...v4.0.1) (2019-07-16) + + +### Bug Fixes + +* **exams:** fix caculation of maximum exercise points ([a9e74ca](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a9e74ca)) + + + +## [4.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v3.0.0...v4.0.0) (2019-07-16) + + +### Features + +* **csv:** add column explanations ([c8dca94](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/c8dca94)) + + +### BREAKING CHANGES + +* **csv:** CsvColumnsExplained now required + + + +## [3.0.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v2.1.1...v3.0.0) (2019-07-16) + + +### Bug Fixes + +* **course and exam registration:** distinguish registrations buttons ([ad825b6](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ad825b6)), closes [#416](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/416) +* **exam participant download:** fix icon not being shown ([a075b16](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a075b16)) +* **exams:** cleanup exam interface ([05e7b52](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/05e7b52)) +* **sheet type info:** give better tooltips and name to sheet types ([9dbef1f](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/9dbef1f)), closes [#402](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/issues/402) + + +### Features + +* **exams:** csv-export exercise data ([2218103](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2218103)) +* **exams:** filter on occurrence ([cf040ce](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf040ce)) +* **exams:** introduce examOccurrenceName ([379a7ed](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/379a7ed)) +* **exams:** show exam bonus in webinterface ([2b23600](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/2b23600)) +* **sheetlist:** sort sheet file types in db by haskell Ord ([643cc41](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/643cc41)) + + +### BREAKING CHANGES + +* **exams:** examOccurrenceName +* **exams:** examStart and examPublishOccurrenceAssignments now optional + + + ### [2.1.1](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v2.1.0...v2.1.1) (2019-07-10) diff --git a/frontend/src/utils/inputs/file-input.js b/frontend/src/utils/inputs/file-input.js index 676d6ff2c..568e1baf4 100644 --- a/frontend/src/utils/inputs/file-input.js +++ b/frontend/src/utils/inputs/file-input.js @@ -1,4 +1,5 @@ import { Utility } from '../../core/utility'; +import './file-input.scss'; const FILE_INPUT_CLASS = 'file-input'; const FILE_INPUT_INITIALIZED_CLASS = 'file-input--initialized'; diff --git a/frontend/src/utils/inputs/file-input.scss b/frontend/src/utils/inputs/file-input.scss new file mode 100644 index 000000000..7bf23248d --- /dev/null +++ b/frontend/src/utils/inputs/file-input.scss @@ -0,0 +1,3 @@ +.file-input__list:empty { + display: none; +} diff --git a/frontend/src/utils/inputs/inputs.scss b/frontend/src/utils/inputs/inputs.scss index 817534357..643902d08 100644 --- a/frontend/src/utils/inputs/inputs.scss +++ b/frontend/src/utils/inputs/inputs.scss @@ -25,6 +25,11 @@ color: var(--color-fontsec); } +.form-section-legend { + color: var(--color-fontsec); + margin: 7px 0; +} + .form-group-label { font-weight: 600; padding-top: 6px; @@ -36,11 +41,9 @@ font-size: 0.9rem; } -.form-group--required { - .form-group-label__caption::after { - content: ' *'; - color: var(--color-error); - } +.form-group--required .form-group-label__caption::after, .form-group__required-marker::before { + content: ' *'; + color: var(--color-error); } .form-group--optional { diff --git a/frontend/src/utils/modal/modal.scss b/frontend/src/utils/modal/modal.scss index 2cecac941..50054aaaf 100644 --- a/frontend/src/utils/modal/modal.scss +++ b/frontend/src/utils/modal/modal.scss @@ -83,6 +83,10 @@ cursor: pointer; } +div.modal__trigger { + display: inline-block; +} + .modal__trigger-label { font-style: italic; text-decoration: underline; diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 78a7b7d42..86cd283e6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -5,6 +5,10 @@ BtnAbort: Abbrechen BtnDelete: Löschen BtnRegister: Anmelden BtnDeregister: Abmelden +BtnCourseRegister: Zum Kurs anmelden +BtnCourseDeregister: Vom Kurs abmelden +BtnExamRegister: Anmelden zur Klausur +BtnExamDeregister: Von der Klausur abmelden BtnHijack: Sitzung übernehmen BtnSave: Speichern PressSaveToSave: Änderungen werden erst durch Drücken des Knopfes "Speichern" gespeichert. @@ -87,6 +91,7 @@ CourseDeregisterOk: Erfolgreich abgemeldet CourseDeregisterLecturerTip: Wenn Sie den Teilnehmer vom Kurs abmelden kann es sein, dass sie Zugriff auf diese Daten verlieren CourseStudyFeature: Assoziiertes Hauptfach CourseStudyFeatureUpdated: Assoziiertes Hauptfach geändert +CourseStudyFeatureNone: Kein assoziiertes Hauptfach CourseTutorial: Tutorium CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort @@ -435,7 +440,9 @@ HasCorrector: Korrektor zugeteilt AssignedTime: Zuteilung AchievedBonusPoints: Erreichte Bonuspunkte AchievedNormalPoints: Erreichte Punkte -AchievedPassPoints: Erreichte Punkte +AchievedPoints: Erreichte Punkte +AchievedPassPoints: Erreichte Punkte zum Bestehen +AchievedPasses: Bestandene Blätter AchievedOf achieved@Points possible@Points: #{achieved} von #{possible} PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{points} von #{maxPoints} (Bestanden ab #{passingPoints}) PassedResult: Ergebnis @@ -521,6 +528,7 @@ NotificationSettings: Erwünschte Benachrichtigungen FormNotifications: Benachrichtigungen FormBehaviour: Verhalten FormCosmetics: Oberfläche +FormFieldRequiredTip: Gekennzeichnete Pflichtfelder sind immer auszufüllen ActiveAuthTags: Aktivierte Authorisierungsprädikate @@ -580,6 +588,8 @@ SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahr SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen. SubmissionReplace: Abgabe ersetzen +SubmissionCreated: Abgabe erfolgreich angelegt +SubmissionUpdated: Abgabe erfolgreich ersetzt AdminFeaturesHeading: Studiengänge StudyTerms: Studiengänge @@ -660,7 +670,7 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{tid}-#{ssh}-#{csh}] Einladung zum Tutor für #{tutn} -MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für Klausur #{examn} +MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{tid}-#{ssh}-#{csh}] Einladung zum Korrektor für #{examn} MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} @@ -678,10 +688,11 @@ SheetGradingPassBinary': Bestanden/Nicht bestanden 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. +SheetTypeInformational grading@SheetGrading: Ohne Anrechung +SheetTypeNotGraded: Keine Korrektur +SheetTypeInfoNotGraded: Keine Korrektur bedeutet, dass es gar kein Feedback gibt. SheetTypeInfoBonus: Bonus Blätter zählen normal, erhöhen aber nicht die maximal erreichbare Punktzahl bzw. Anzahl zu bestehender Blätter. +SheetTypeInfoInformational: Blätter ohne Anrechnung werden nirgends angerechnet, die Bewertung durch den Korrektor dient lediglich zur Information der Teilnehmer. SheetGradingBonusIncluded: Erzielte Bonuspunkte wurden hier bereits zu den erreichten normalen Punkten hinzugezählt. SummaryTitle: Zusammenfassung über SheetGradingSummaryTitle intgr@Integer: #{intgr} #{pluralDE intgr "Blatt" "Blätter"} @@ -689,8 +700,8 @@ SubmissionGradingSummaryTitle intgr@Integer: #{intgr} #{pluralDE intgr "Abgabe" SheetTypeBonus': Bonus SheetTypeNormal': Normal -SheetTypeInformational': Keine Wertung -SheetTypeNotGraded': Unbewertet +SheetTypeInformational': Ohne Anrechung +SheetTypeNotGraded': Keine Korrektur SheetGradingMaxPoints: Maximalpunktzahl SheetGradingPassingPoints: Notwendig zum Bestehen @@ -927,6 +938,8 @@ CommTutorialHeading: Tutorium-Mitteilung RecipientCustom: Weitere Empfänger RecipientToggleAll: Alle/Keine +DBCsvImportActionToggleAll: Alle/Keine + RGCourseParticipants: Kursteilnehmer RGCourseLecturers: Kursverwalter RGCourseCorrectors: Korrektoren @@ -960,9 +973,9 @@ TutorInvitationDeclined tutn@TutorialName: Sie haben die Einladung, Tutor für # TutorInviteHeading tutn@TutorialName: Einladung zum Tutor für #{tutn} TutorInviteExplanation: Sie wurden eingeladen, Tutor zu sein. -ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für Klausur #{examn} eingetragen -ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für Klausur #{examn} zu werden, abgelehnt -ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für Klausur #{examn} +ExamCorrectorInvitationAccepted examn@ExamName: Sie wurden als Korrektor für #{examn} eingetragen +ExamCorrectorInvitationDeclined examn@ExamName: Sie haben die Einladung, Korrektor für #{examn} zu werden, abgelehnt +ExamCorrectorInviteHeading examn@ExamName: Einladung zum Korrektor für #{examn} ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein. SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen @@ -1056,7 +1069,7 @@ HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus CourseParticipants n@Int: Derzeit #{n} angemeldete Kursteilnehmer CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt CourseParticipantsAlreadyRegistered n@Int: #{n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet -CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} +CourseParticipantsRegisteredWithoutField n@Int: #{n} Teilnehmer #{pluralDE n "wurde ohne assoziiertes Hauptfach" "wurden ohne assoziierte Hauptfächer"} angemeldet, da #{pluralDE n "kein eindeutiges Hauptfach bestimmt werden konnte" "keine eindeutigen Hauptfächer bestimmt werden konnten"} CourseParticipantsRegistered n@Int: #{n} Teilnehmer erfolgreich angemeldet CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen @@ -1073,9 +1086,9 @@ ExamRegisterFrom: Anmeldung ab ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klausur anmelden können; ohne Datum ist keine Anmeldung möglich ExamRegisterTo: Anmeldung bis ExamDeregisterUntil: Abmeldung bis -ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um -ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welchen Teilprüfungen (Räumen) sie angemeldet sind -ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab +ExamPublishOccurrenceAssignments: Termin- bzw. Raumzuteilung den Teilnehmern mitteilen um +ExamPublishOccurrenceAssignmentsTip: Ab diesem Zeitpunkt Teilnehmer einsehen zu welcher Teilprüfung bzw. welchen Raum sie angemeldet sind +ExamPublishOccurrenceAssignmentsParticipant: Termin- bzw. Raumzuteilung einsehbar ab ExamFinished: Bewertung abgeschlossen ab ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden @@ -1086,7 +1099,7 @@ ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder ExamPublicStatistics: Statistik veröffentlichen ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können? ExamGradingRule: Notenberechnung -ExamGradingManual': Manuell +ExamGradingManual': Keine automatische Berechnung ExamGradingKey': Nach Schlüssel ExamGradingKey: Notenschlüssel ExamGradingKeyTip: Die Grenzen beziehen sich auf die effektive Maximalpunktzahl, nachdem etwaige Bonuspunkte aus dem Übungsbetrieb angerechnet und die Ergebnise der Teilaufgaben mit ihrem Gewicht multipliziert wurden @@ -1096,7 +1109,7 @@ PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein GradingFrom: Ab ExamNew: Neue Klausur ExamBonusRule: Klausurbonus aus Übungsbetrieb -ExamNoBonus': Kein Bonus +ExamNoBonus': Kein automatischer Bonus ExamBonusPoints': Umrechnung von Übungspunkten ExamEditHeading examn@ExamName: #{examn} bearbeiten @@ -1105,15 +1118,19 @@ ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen -ExamOccurrenceRule: Automatische Terminzuteilung -ExamOccurrenceRuleParticipant: Terminzuteilung +ExamOccurrenceRule: Automatische Termin- bzw. Raumzuteilung +ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilung ExamRoomManual': Keine automatische Zuteilung ExamRoomSurname': Nach Nachname ExamRoomMatriculation': Nach Matrikelnummer ExamRoomRandom': Zufällig pro Teilnehmer +ExamOccurrence: Termin/Raum +ExamNoOccurrence: Kein Termin/Raum ExamOccurrences: Prüfungen +ExamRooms: Räume ExamRoomAlreadyExists: Prüfung ist bereits eingetragen +ExamRoomName: Interne Bezeichnung ExamRoom: Raum ExamRoomCapacity: Kapazität ExamRoomCapacityNegative: Kapazität darf nicht negativ sein @@ -1125,7 +1142,7 @@ ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe ExamRoomRegistered: Zugeteilt ExamFormTimes: Zeiten -ExamFormOccurrences: Prüfungstermine +ExamFormOccurrences: Prüfungstermine/Räume ExamFormAutomaticFunctions: Automatische Funktionen ExamFormCorrection: Korrektur ExamFormParts: Teile @@ -1142,8 +1159,8 @@ ExamPartWeight: Gewichtung ExamPartResultPoints: Erreichte Punkte ExamNameTaken exam@ExamName: Es existiert bereits eine Klausur mit Namen #{exam} -ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt -ExamEdited exam@ExamName: Klausur #{exam} erfolgreich bearbeitet +ExamCreated exam@ExamName: #{exam} erfolgreich angelegt +ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet ExamNoShow: Nicht erschienen ExamVoided: Entwertet @@ -1155,15 +1172,15 @@ ExamPassed: Bestanden ExamNotPassed: Nicht bestanden ExamResult: Klausurergebnis -ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet -ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet +ExamRegisteredSuccess exam@ExamName: Erfolgreich zur #{exam} angemeldet +ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der #{exam} abgemeldet ExamRegistered: Angemeldet ExamNotRegistered: Nicht angemeldet ExamRegistration: Anmeldung ExamRegisterToMustBeAfterRegisterFrom: "Anmeldung ab" muss vor "Anmeldung bis" liegen ExamDeregisterUntilMustBeAfterRegisterFrom: "Abmeldung bis" muss nach "Anmeldung bis" liegen -ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Terminzuordnung liegen +ExamStartMustBeAfterPublishOccurrenceAssignments: Start muss nach Veröffentlichung der Termin- bzw. Raumzuordnung liegen ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen ExamFinishedMustBeAfterEnd: "Bewertung abgeschlossen ab" muss nach Ende liegen ExamFinishedMustBeAfterStart: "Bewertung abgeschlossen ab" muss nach Start liegen @@ -1171,14 +1188,69 @@ ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abges ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen +ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen +ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Klausur liegen +ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} muss vor Ende der Klausur liegen +ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor +ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor + VersionHistory: Versionsgeschichte KnownBugs: Bekannte Bugs ExamUsersHeading: Klausurteilnehmer +ExamUserDeregister: Teilnehmer von Klausur abmelden +ExamUserAssignOccurrence: Termin/Raum zuweisen +ExamUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +ExamUsersOccurrenceUpdated count@Int64: Termin/Raum für #{show count} Teilnehmer gesetzt CsvFile: CSV-Datei CsvModifyExisting: Existierende Einträge angleichen CsvAddNew: Neue Einträge einfügen CsvDeleteMissing: Fehlende Einträge entfernen BtnCsvExport: CSV-Datei exportieren -BtnCsvImport: CSV-Datei importieren \ No newline at end of file +BtnCsvImport: CSV-Datei importieren +BtnCsvImportConfirm: CSV-Import abschließen + +CsvImportNotConfigured: CSV-Import nicht vorgesehen +CsvImportConfirmationHeading: CSV-Import abschließen +CsvImportConfirmationTip: Durch den CSV-Import würden die unten aufgeführten Änderungen vorgenommen. Bitte überprüfen Sie diese zunächst sorgfältig. +CsvImportUnnecessary: Durch den CSV-Import würden keine Änderungen vorgenommen werden +CsvImportSuccessful n@Int: CSV-Import erfolgreich, es #{pluralDE n "wurde eine Aktion" (mappend (mappend "wurden " (toMessage n)) " Aktionen")} durchgeführt +CsvImportAborted: CSV-Import abgebrochen + +Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * prop)}%) + +CsvColumnsExplanationsLabel: Spalten +CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten +CsvColumnExamUserSurname: Nachname des Teilnehmers +CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname) +CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers +CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat +CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt +CsvColumnExamUserSemester: Fachsemester des Teilnehmers im assoziierten Hauptfach +CsvColumnExamUserOccurrence: Prüfungstermin/-Raum, zu dem der Teilnehmer angemeldet ist +CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb erreicht hat +CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können +CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat +CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können + +Action: Aktion + +DBCsvDuplicateKey: Zwei Zeilen der CSV-Dateien referenzieren den selben internen Datensatz und können daher nicht verarbeitet werden. +DBCsvDuplicateKeyTip: Entfernen Sie eine der unten aufgeführten Zeilen aus Ihren CSV-Dateien und versuchen Sie es erneut. +DBCsvKeyException: Für eine Zeile der CSV-Dateien konnte nicht festgestellt werden, ob sie zu einem bestehenden internen Datensatz korrespondieren. +DBCsvException: Bei der Berechnung der auszuführenden Aktionen für einen Datensatz ist ein Fehler aufgetreten. + +ExamUserCsvCourseRegister: Benutzer zum Kurs und zur Klausur anmelden +ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden +ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen +ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden +ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern + +ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden +ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden +ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig identifiziert werden + +TableHeadingFilter: Filter +TableHeadingCsvImport: CSV-Import +TableHeadingCsvExport: CSV-Export \ No newline at end of file diff --git a/models/exams b/models/exams index 809ba3f1b..a98a427ca 100644 --- a/models/exams +++ b/models/exams @@ -8,8 +8,8 @@ Exam registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe - publishOccurrenceAssignments UTCTime - start UTCTime + publishOccurrenceAssignments UTCTime Maybe + start UTCTime Maybe end UTCTime Maybe finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification) @@ -25,11 +25,13 @@ ExamPart UniqueExamPart exam name ExamOccurrence exam ExamId + name ExamOccurrenceName room Text capacity Natural start UTCTime end UTCTime Maybe description Html Maybe + UniqueExamOccurrence exam name ExamRegistration exam ExamId user UserId diff --git a/package-lock.json b/package-lock.json index 1a173ab68..49c5066b7 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "2.1.1", + "version": "4.2.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index b396fbdbf..60dfd1f05 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "2.1.1", + "version": "4.2.0", "description": "", "keywords": [], "author": "", @@ -20,7 +20,9 @@ "frontend:test:watch": "karma start --conf karma.conf.js --single-run false", "frontend:build": "webpack", "frontend:build:watch": "webpack --watch", - "release": "standard-version -a" + "prerelease": "npm run test", + "release": "standard-version -a", + "postrelease": "git push --follow-tags origin master" }, "husky": { "hooks": { diff --git a/package.yaml b/package.yaml index edeaae4b1..cf631c001 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 2.1.1 +version: 4.2.0 dependencies: # Due to a bug in GHC 8.0.1, we block its usage diff --git a/routes b/routes index a6241127d..3b1aa5262 100644 --- a/routes +++ b/routes @@ -143,7 +143,7 @@ /show EShowR GET !time /edit EEditR GET POST /corrector-invite ECInviteR GET POST - /users EUsersR GET POST !timeANDcorrector + /users EUsersR GET POST /users/new EAddUserR GET POST /users/invite EInviteR GET POST /register ERegisterR POST !timeANDcourse-registered !timeANDexam-registered diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 5987caa4f..9f6ad4964 100644 --- a/src/Auth/Dummy.hs +++ b/src/Auth/Dummy.hs @@ -32,6 +32,7 @@ dummyLogin :: ( YesodAuth site , YesodPersist site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage + , RenderMessage site AFormMessage , RenderMessage site DummyMessage , Button site ButtonSubmit ) => AuthPlugin site diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 9ea9d02e5..4f003471a 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -73,6 +73,7 @@ campusLogin :: forall site. ( YesodAuth site , RenderMessage site FormMessage , RenderMessage site CampusMessage + , RenderMessage site AFormMessage , Button site ButtonSubmit ) => LdapConf -> LdapPool -> AuthPlugin site campusLogin conf@LdapConf{..} pool = AuthPlugin{..} @@ -91,7 +92,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..} Ldap.bind ldap ldapDn ldapPassword searchResults <- findUser conf ldap campusIdent [userPrincipalName] case searchResults of - [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] + [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] | Just [principalName] <- lookup userPrincipalName userAttrs , Right credsIdent <- Text.decodeUtf8' principalName -> Right (userDN, credsIdent) <$ Ldap.bind ldap (Ldap.Dn credsIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword) diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index a4eb42057..d6f5bf4e8 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -40,6 +40,7 @@ hashLogin :: ( YesodAuth site , SqlBackendCanRead (YesodPersistBackend site) , RenderMessage site FormMessage , RenderMessage site PWHashMessage + , RenderMessage site AFormMessage , Button site ButtonSubmit ) => PWHashAlgorithm -> AuthPlugin site hashLogin pwHashAlgo = AuthPlugin{..} diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs index b6b69fa02..937fb2c46 100644 --- a/src/Data/CaseInsensitive/Instances.hs +++ b/src/Data/CaseInsensitive/Instances.hs @@ -29,6 +29,8 @@ import Web.HttpApiData import Data.Binary (Binary) import qualified Data.Binary as Binary +import qualified Data.Csv as Csv + instance PersistField (CI Text) where toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText @@ -86,11 +88,11 @@ instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where fromPathPiece = fmap CI.mk . fromPathPiece toPathPiece = toPathPiece . CI.original -instance ToHttpApiData (CI Text) where +instance ToHttpApiData s => ToHttpApiData (CI s) where toUrlPiece = toUrlPiece . CI.original toEncodedUrlPiece = toEncodedUrlPiece . CI.original -instance FromHttpApiData (CI Text) where +instance (CI.FoldCase s, FromHttpApiData s) => FromHttpApiData (CI s) where parseUrlPiece = fmap CI.mk . parseUrlPiece instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where @@ -101,3 +103,9 @@ instance (CI.FoldCase s, Binary s) => Binary (CI s) where get = CI.mk <$> Binary.get put = Binary.put . CI.original putList = Binary.putList . map CI.original + +instance Csv.ToField s => Csv.ToField (CI s) where + toField = Csv.toField . CI.original + +instance (CI.FoldCase s, Csv.FromField s) => Csv.FromField (CI s) where + parseField = fmap CI.mk . Csv.parseField diff --git a/src/Data/Fixed/Instances.hs b/src/Data/Fixed/Instances.hs index 03afaeb0e..53696e9e6 100644 --- a/src/Data/Fixed/Instances.hs +++ b/src/Data/Fixed/Instances.hs @@ -9,5 +9,18 @@ import Data.Fixed import Text.Blaze (ToMarkup(..)) +import qualified Data.Csv as Csv + +import Data.Proxy (Proxy(..)) + +import Data.Scientific + + instance HasResolution a => ToMarkup (Fixed a) where - toMarkup = toMarkup . showFixed True \ No newline at end of file + toMarkup = toMarkup . showFixed True + + +instance HasResolution a => Csv.ToField (Fixed a) where + toField = Csv.toField . (realToFrac :: Fixed a -> Scientific) +instance HasResolution a => Csv.FromField (Fixed a) where + parseField = fmap (MkFixed . (round :: Scientific -> Integer) . (* fromInteger (resolution $ Proxy @a))) . Csv.parseField diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs index 8a00de5e3..38b20d104 100644 --- a/src/Data/UUID/Instances.hs +++ b/src/Data/UUID/Instances.hs @@ -3,12 +3,13 @@ module Data.UUID.Instances () where -import ClassyPrelude +import ClassyPrelude.Yesod import Data.UUID (UUID) import qualified Data.UUID as UUID import Database.Persist.Sql -import Web.PathPieces + +import Text.Blaze (ToMarkup(..)) instance PathPiece UUID where @@ -25,3 +26,13 @@ instance PersistField UUID where instance PersistFieldSql UUID where sqlType _ = SqlOther "uuid" + +instance ToMarkup UUID where + toMarkup uuid = [shamlet| + $newline never + + #{UUID.toText uuid} + |] + +instance ToWidget site UUID where + toWidget = toWidget . toMarkup diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index cc8ffbb24..a3bf2192a 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -4,20 +4,30 @@ module Database.Esqueleto.Utils ( true, false , isJust , isInfixOf, hasInfix + , or, and , any, all , SqlIn(..) , mkExactFilter, mkExactFilterWith , mkContainsFilter, mkContainsFilterWith , mkExistsFilter , anyFilter, allFilter + , orderByOrd, orderByEnum + , lower, ciEq ) where -import ClassyPrelude.Yesod hiding (isInfixOf, any, all, isJust) + +import ClassyPrelude.Yesod hiding (isInfixOf, any, all, or, and, isJust) +import Data.Universe import qualified Data.Set as Set +import qualified Data.List as List import qualified Data.Foldable as F import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E import Database.Esqueleto.Utils.TH +{-# ANN any ("HLint: ignore Use any" :: String) #-} +{-# ANN all ("HLint: ignore Use all" :: String) #-} + -- -- Description : Convenience for using `Esqueleto`, @@ -54,17 +64,19 @@ hasInfix :: ( E.Esqueleto query expr backend => expr (E.Value s2) -> expr (E.Value s1) -> expr (E.Value Bool) hasInfix = flip isInfixOf +and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool) +and = F.foldr (E.&&.) true +or = F.foldr (E.||.) false + -- | Given a test and a set of values, check whether anyone succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated) -any :: Foldable f => - (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) -any test = F.foldr (\needle acc -> acc E.||. test needle) false +any :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool) +any test = or . map test . otoList -- | Given a test and a set of values, check whether all succeeds the test -- WARNING: SQL leaves it explicitely unspecified whether `&&` is short curcuited (i.e. lazily evaluated) -all :: Foldable f => - (a -> E.SqlExpr (E.Value Bool)) -> f a -> E.SqlExpr (E.Value Bool) -all test = F.foldr (\needle acc -> acc E.&&. test needle) true +all :: MonoFoldable f => (Element f -> E.SqlExpr (E.Value Bool)) -> f -> E.SqlExpr (E.Value Bool) +all test = and . map test . otoList -- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples @@ -113,7 +125,7 @@ mkContainsFilter :: E.SqlString a -> Set.Set a -- ^ needle collection -> E.SqlExpr (E.Value Bool) mkContainsFilter = mkContainsFilterWith id - + -- | like `mkContainsFiler` but allows for conversion; convenient in conjunction with `anyFilter` and `allFilter` mkContainsFilterWith :: E.SqlString b => (a -> b) @@ -132,7 +144,7 @@ mkExistsFilter :: PathPiece a -> E.SqlExpr (E.Value Bool) mkExistsFilter query row criterias | Set.null criterias = true - | otherwise = any (E.exists . query row) criterias + | otherwise = any (E.exists . query row) $ Set.toList criterias -- | Combine several filters, using logical or anyFilter :: (Foldable f) @@ -153,3 +165,18 @@ allFilter :: (Foldable f) allFilter fltrs needle criterias = F.foldr aux true fltrs where aux fltr acc = fltr needle criterias E.&&. acc + + +orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) +orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism + \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1)) + +orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int) +orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1)) + + +lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) +lower = E.unsafeSqlFunction "LOWER" + +ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool) +ciEq a b = lower a E.==. lower b diff --git a/src/Foundation.hs b/src/Foundation.hs index 46ed9addf..1a5bd92b4 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -294,6 +294,8 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr in verbMap . splitCamel embedRenderMessage ''UniWorX ''UploadModeDescr id embedRenderMessage ''UniWorX ''SecretJSONFieldException id +embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel + newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -677,7 +679,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of case subRoute of EShowR -> guard visible - EUsersR -> guard $ examStart <= cTime + EUsersR -> guard $ NTop examStart <= NTop (Just cTime) && NTop (Just cTime) <= NTop examFinished ERegisterR | not registered -> guard $ visible diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index f1d5085a5..3e0a5a825 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -168,7 +168,7 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let - protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) + protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (fromMaybe mempty userMatrikelnummer) in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary)) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 7367151a2..d668a197a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -47,6 +47,21 @@ import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) +-- Dedicated CourseRegistrationButton +data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonCourseRegister +instance Finite ButtonCourseRegister +nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonCourseRegister id +instance Button UniWorX ButtonCourseRegister where + btnClasses BtnCourseRegister = [BCIsButton, BCPrimary] + btnClasses BtnCourseDeregister = [BCIsButton, BCDanger] + + btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|] + btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|] + + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School, [Entity User]) @@ -341,7 +356,7 @@ getCShowR tid ssh csh = do mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration - (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course + (regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course let regForm = wrapForm regWidget def { formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR , formEncoding = regEnctype @@ -433,33 +448,34 @@ getCShowR tid ssh csh = do guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR return r dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) (toWidget examName) + [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do - startT <- formatTime SelFormatDateTime examStart - endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd - [whamlet| - $newline never - #{startT} - $maybe endT' <- endT - \ – #{endT'} - |] - , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do + , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart + , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True isRegistered <- case mbAid of Nothing -> return False Just uid -> existsBy $ UniqueExamRegistration eId uid - if - | mayRegister -> do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered - return $ wrapForm examRegisterForm def - { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR - , formEncoding = examRegisterEnctype - , formSubmit = FormNoSubmit - } - | isRegistered -> return [whamlet|_{MsgExamRegistered}|] - | otherwise -> return mempty + let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered + examUrl = CExamR tid ssh csh examName EShowR + if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl + | otherwise -> return [whamlet|_{label}|] + -- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do + -- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True + -- isRegistered <- case mbAid of + -- Nothing -> return False + -- Just uid -> existsBy $ UniqueExamRegistration eId uid + -- if + -- | mayRegister -> do + -- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered + -- return $ wrapForm examRegisterForm def + -- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR + -- , formEncoding = examRegisterEnctype + -- , formSubmit = FormNoSubmit + -- } + -- | isRegistered -> return [whamlet|_{MsgExamRegistered}|] + -- | otherwise -> return mempty ] dbtSorting = Map.fromList [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) @@ -467,6 +483,14 @@ getCShowR tid ssh csh = do , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) + , ("registered", SortColumn $ \exam -> + case mbAid of + Nothing -> E.false + Just uid -> + E.exists $ E.from $ \reg -> do + E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid + E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId + ) ] dbtFilter = Map.empty dbtFilterUI = const mempty @@ -489,9 +513,9 @@ getCShowR tid ssh csh = do -- , maybe existing features if already registered -- , maybe some default study features -- , maybe a course secret -registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) +courseRegisterForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) -- unfinished WIP: must take study features if registred and show as mforced field -registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do +courseRegisterForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do -- secret fields (msecretRes', msecretView) <- case msecret of (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing @@ -505,7 +529,7 @@ registerForm loggedin participant defSFid msecret = identifyForm FIDcourseRegist _other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid) -- button de-/register - (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing + (btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister isRegistered) "buttonField ignores settings anyway" Nothing let widget = $(widgetFile "widgets/register-form/register-form") let msecretRes | Just res <- msecretRes' = Just <$> res @@ -540,7 +564,7 @@ postCRegisterR tid ssh csh = do registration <- getBy (UniqueParticipant aid cid) return (cid, course, entityVal <$> registration) let isRegistered = isJust registration - ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course + ((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course formResult regResult $ \(mbSfId,codeOk) -> if | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid @@ -1072,7 +1096,7 @@ colUserComment tid ssh csh = sortable (Just "note") (i18nCell MsgCourseUserNote) $ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } -> maybeEmpty mbNoteKey $ const $ - anchorCellM (courseLink <$> encrypt uid) (toWidget $ hasComment True) + anchorCellM (courseLink <$> encrypt uid) (hasComment True) where courseLink = CourseR tid ssh csh . CUserR @@ -1386,8 +1410,8 @@ postCUserR tid ssh csh uCId = do redirect $ currentRoute :#: registrationFieldFrag let regButton - | Just _ <- mRegistration = BtnDeregister - | otherwise = BtnRegister + | Just _ <- mRegistration = BtnCourseDeregister + | otherwise = BtnCourseRegister ((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton] let registrationButtonFrag :: Text @@ -1401,7 +1425,7 @@ postCUserR tid ssh csh uCId = do , formAnchor = Just registrationButtonFrag } formResult regButtonRes $ \case - BtnDeregister + BtnCourseDeregister | Just (Entity pId _) <- mRegistration -> do runDB $ delete pId @@ -1409,7 +1433,7 @@ postCUserR tid ssh csh uCId = do redirect $ CourseR tid ssh csh CUsersR | otherwise -> invalidArgs ["User not registered"] - BtnRegister -> do + BtnCourseRegister -> do now <- liftIO getCurrentTime let primaryField | [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 1758e3ffa..e8c2b8ea4 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -13,7 +13,7 @@ import Handler.Utils.Csv import Jobs.Queue import Utils.Lens hiding (parts) - + import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH @@ -22,6 +22,9 @@ import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.Lens as Text + import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) import Text.Blaze.Html.Renderer.String (renderHtml) @@ -29,11 +32,33 @@ import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.CaseInsensitive as CI import qualified Control.Monad.State.Class as State +import Control.Arrow (Kleisli(..)) import qualified Data.Csv as Csv import qualified Data.Conduit.List as C +import Numeric.Lens (integral) + +import Database.Persist.Sql (deleteWhereCount, updateWhereCount) + + + +-- Dedicated ExamRegistrationButton +data ButtonExamRegister = BtnExamRegister | BtnExamDeregister + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonExamRegister +instance Finite ButtonExamRegister +nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''ButtonExamRegister id +instance Button UniWorX ButtonExamRegister where + btnClasses BtnExamRegister = [BCIsButton, BCPrimary] + btnClasses BtnExamDeregister = [BCIsButton, BCDanger] + + btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|] + btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|] + + getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do @@ -52,19 +77,11 @@ getCExamListR tid ssh csh = do guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR return x dbtColonnade = dbColonnade . mconcat $ catMaybes - [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) $ toWidget examName + [ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName , (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom , Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do - startT <- formatTime SelFormatDateTime examStart - endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd - [whamlet| - $newline never - #{startT} - $maybe endT' <- endT - \ – #{endT'} - |] + , Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart ] dbtSorting = Map.fromList [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) @@ -90,7 +107,7 @@ getCExamListR tid ssh csh = do setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading $(widgetFile "exam-list") - + instance IsInvitableJunction ExamCorrector where type InvitationFor ExamCorrector = Exam data InvitableJunction ExamCorrector = JunctionExamCorrector @@ -154,13 +171,13 @@ postECInviteR = invitationR examCorrectorInvitationConfig data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html - , efStart :: UTCTime + , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime , efRegisterFrom :: Maybe UTCTime , efRegisterTo :: Maybe UTCTime , efDeregisterUntil :: Maybe UTCTime - , efPublishOccurrenceAssignments :: UTCTime + , efPublishOccurrenceAssignments :: Maybe UTCTime , efFinished :: Maybe UTCTime , efClosed :: Maybe UTCTime , efOccurrences :: Set ExamOccurrenceForm @@ -175,6 +192,7 @@ data ExamForm = ExamForm data ExamOccurrenceForm = ExamOccurrenceForm { eofId :: Maybe CryptoUUIDExamOccurrence + , eofName :: ExamOccurrenceName , eofRoom :: Text , eofCapacity :: Natural , eofStart :: UTCTime @@ -189,6 +207,8 @@ data ExamPartForm = ExamPartForm , epfWeight :: Rational } deriving (Read, Show, Eq, Ord, Generic, Typeable) +makeLenses_ ''ExamForm + deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''ExamPartForm @@ -206,13 +226,13 @@ examForm template html = do <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template)) <* aformSection MsgExamFormTimes - <*> areq utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) + <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) <*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template) <*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template) <*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template) <*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template) - <*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (efPublishOccurrenceAssignments <$> template) + <*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template) <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) <* aformSection MsgExamFormOccurrences @@ -221,7 +241,7 @@ examForm template html = do <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template)) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) <*> examGradingRuleForm (efGradingRule <$> template) - <*> bonusRuleForm (efBonusRule <$> template) + <*> examBonusRuleForm (efBonusRule <$> template) <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) @@ -272,7 +292,7 @@ examCorrectorsForm mPrev = wFormToAForm $ do miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) () miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout") - fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) True (Set.toList <$> mPrev) + fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev) examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) examOccurrenceForm prev = wFormToAForm $ do @@ -280,12 +300,13 @@ examOccurrenceForm prev = wFormToAForm $ do let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag - - fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ Set.toList <$> prev + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev where examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) - (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) + (eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev) + (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev) (eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) @@ -293,6 +314,7 @@ examOccurrenceForm prev = wFormToAForm $ do return ( ExamOccurrenceForm <$> eofIdRes + <*> eofNameRes <*> eofRoomRes <*> eofCapacityRes <*> eofStartRes @@ -300,7 +322,7 @@ examOccurrenceForm prev = wFormToAForm $ do <*> (assertM (not . null . renderHtml) <$> eofDescRes) , $(widgetFile "widgets/massinput/examRooms/form") ) - + miAdd' nudge submitView csrf = do MsgRenderer mr <- getMsgRenderer (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf @@ -320,8 +342,8 @@ examPartsForm prev = wFormToAForm $ do let miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag - - fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev + + fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev where examPartForm' nudge mPrev csrf = do (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) @@ -336,7 +358,7 @@ examPartsForm prev = wFormToAForm $ do <*> epfWeightRes , $(widgetFile "widgets/massinput/examParts/form") ) - + miAdd' nudge submitView csrf = do MsgRenderer mr <- getMsgRenderer (res, formWidget) <- examPartForm' nudge Nothing csrf @@ -348,7 +370,7 @@ examPartsForm prev = wFormToAForm $ do miCell' nudge dat = examPartForm' nudge (Just dat) miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") miIdent' :: Text - miIdent' = "exam-parts" + miIdent' = "exam-parts" examFormTemplate :: Entity Exam -> DB ExamForm examFormTemplate (Entity eId Exam{..}) = do @@ -381,6 +403,7 @@ examFormTemplate (Entity eId Exam{..}) = do (Just -> eofId, ExamOccurrence{..}) <- occurrences' return ExamOccurrenceForm { eofId + , eofName = examOccurrenceName , eofRoom = examOccurrenceRoom , eofCapacity = examOccurrenceCapacity , eofStart = examOccurrenceStart @@ -406,7 +429,7 @@ examFormTemplate (Entity eId Exam{..}) = do examTemplate :: CourseId -> DB (Maybe ExamForm) examTemplate cid = runMaybeT $ do newCourse <- MaybeT $ get cid - + [(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse) @@ -425,7 +448,7 @@ examTemplate cid = runMaybeT $ do newTerm <- MaybeT . get $ courseTerm newCourse let - dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm + dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm return ExamForm { efName = examName oldExam @@ -436,8 +459,8 @@ examTemplate cid = runMaybeT $ do , efRegisterFrom = dateOffset <$> examRegisterFrom oldExam , efRegisterTo = dateOffset <$> examRegisterTo oldExam , efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam - , efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam - , efStart = dateOffset $ examStart oldExam + , efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam + , efStart = dateOffset <$> examStart oldExam , efEnd = dateOffset <$> examEnd oldExam , efFinished = dateOffset <$> examFinished oldExam , efClosed = dateOffset <$> examClosed oldExam @@ -453,17 +476,34 @@ examTemplate cid = runMaybeT $ do validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () validateExam = do ExamForm{..} <- State.get - + guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom - guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ efStart >= efPublishOccurrenceAssignments - guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart) + guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments + guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd - guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart) + guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished - guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart) + guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd + forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do + guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart) + guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart + guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd + + forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do + eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a) + + guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b) + [ (/=) `on` eofRoom + , (/=) `on` eofStart + , (/=) `on` eofEnd + , (/=) `on` fmap renderHtml . eofDescription + ] + + guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b + getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR @@ -472,7 +512,7 @@ postCExamNewR tid ssh csh = do cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh template <- examTemplate cid return (cid, template) - + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template formResult newExamResult $ \ExamForm{..} -> do @@ -510,13 +550,14 @@ postCExamNewR tid ssh csh = do [ ExamOccurrence{..} | ExamOccurrenceForm{..} <- Set.toList efOccurrences , let examOccurrenceExam = examid + examOccurrenceName = eofName examOccurrenceRoom = eofRoom examOccurrenceCapacity = eofCapacity examOccurrenceStart = eofStart examOccurrenceEnd = eofEnd examOccurrenceDescription = eofDescription ] - + let (invites, adds) = partitionEithers $ Set.toList efCorrectors insertMany_ [ ExamCorrector{..} | examCorrectorUser <- adds @@ -583,6 +624,7 @@ postEEditR tid ssh csh examn = do ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ ExamOccurrence { examOccurrenceExam = eId + , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart @@ -596,6 +638,7 @@ postEEditR tid ssh csh examn = do guard $ examOccurrenceExam oldOcc == eId lift $ replace eofId' ExamOccurrence { examOccurrenceExam = eId + , examOccurrenceName = eofName , examOccurrenceRoom = eofRoom , examOccurrenceCapacity = eofCapacity , examOccurrenceStart = eofStart @@ -654,14 +697,14 @@ postEEditR tid ssh csh examn = do , formEncoding = editExamEnctype } $(widgetFile "exam-edit") - + getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - - (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do + + (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -669,7 +712,7 @@ getEShowR tid ssh csh examn = do let gradingVisible = NTop (Just cTime) >= NTop examFinished gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR - let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments + let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] @@ -701,13 +744,15 @@ getEShowR tid ssh csh examn = do registered <- for mUid $ existsBy . UniqueExamRegistration eId mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True - return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) + occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) + + let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences registerWidget | Just isRegistered <- registered , mayRegister = Just $ do - (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered [whamlet|

$if isRegistered @@ -757,16 +802,22 @@ queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1) queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures)) queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - + queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration) queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1) +queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence)) +queryExamOccurrence = $(sqlLOJproj 3 2) + queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree)) queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) - + queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms)) queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3) +resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration) +resultExamRegistration = _dbrOutput . _1 + resultUser :: Lens' ExamUserTableData (Entity User) resultUser = _dbrOutput . _2 @@ -775,7 +826,7 @@ resultStudyFeatures = _dbrOutput . _4 . _Just resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree) resultStudyDegree = _dbrOutput . _5 . _Just - + resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms) resultStudyField = _dbrOutput . _6 . _Just @@ -783,18 +834,22 @@ resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence) resultExamOccurrence = _dbrOutput . _3 . _Just data ExamUserTableCsv = ExamUserTableCsv - { csvUserSurname :: Text - , csvUserName :: Text - , csvUserMatriculation :: Maybe Text - , csvUserField :: Maybe Text - , csvUserDegree :: Maybe Text - , csvUserSemester :: Maybe Int - , csvUserRoom :: Maybe Text + { csvEUserSurname :: Maybe Text + , csvEUserName :: Maybe Text + , csvEUserMatriculation :: Maybe Text + , csvEUserField :: Maybe Text + , csvEUserDegree :: Maybe Text + , csvEUserSemester :: Maybe Int + , csvEUserOccurrence :: Maybe (CI Text) + , csvEUserExercisePoints :: Maybe Points + , csvEUserExercisePasses :: Maybe Int + , csvEUserExercisePointsMax :: Maybe Points + , csvEUserExercisePassesMax :: Maybe Int } deriving (Generic) examUserTableCsvOptions :: Csv.Options -examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 1 } +examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 } instance ToNamedRecord ExamUserTableCsv where toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions @@ -805,75 +860,414 @@ instance FromNamedRecord ExamUserTableCsv where instance DefaultOrdered ExamUserTableCsv where headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions +instance CsvColumnsExplained ExamUserTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList + [ ('csvEUserSurname , MsgCsvColumnExamUserSurname ) + , ('csvEUserName , MsgCsvColumnExamUserName ) + , ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation ) + , ('csvEUserField , MsgCsvColumnExamUserField ) + , ('csvEUserDegree , MsgCsvColumnExamUserDegree ) + , ('csvEUserSemester , MsgCsvColumnExamUserSemester ) + , ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence ) + , ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints ) + , ('csvEUserExercisePasses , MsgCsvColumnExamUserExercisePasses ) + , ('csvEUserExercisePointsMax, MsgCsvColumnExamUserExercisePointsMax ) + , ('csvEUserExercisePassesMax, MsgCsvColumnExamUserExercisePassesMax ) + ] + +data ExamUserAction = ExamUserDeregister + | ExamUserAssignOccurrence + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) + +instance Universe ExamUserAction +instance Finite ExamUserAction +nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''ExamUserAction id + +data ExamUserActionData = ExamUserDeregisterData + | ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId) + +data ExamUserCsvActionClass + = ExamUserCsvCourseRegister + | ExamUserCsvRegister + | ExamUserCsvAssignOccurrence + | ExamUserCsvSetCourseField + | ExamUserCsvDeregister + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id + +data ExamUserCsvAction + = ExamUserCsvCourseRegisterData + { examUserCsvActUser :: UserId + , examUserCsvActCourseField :: Maybe StudyFeaturesId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvRegisterData + { examUserCsvActUser :: UserId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvAssignOccurrenceData + { examUserCsvActRegistration :: ExamRegistrationId + , examUserCsvActOccurrence :: Maybe ExamOccurrenceId + } + | ExamUserCsvSetCourseFieldData + { examUserCsvActCourseParticipant :: CourseParticipantId + , examUserCsvActCourseField :: Maybe StudyFeaturesId + } + | ExamUserCsvDeregisterData + { examUserCsvActRegistration :: ExamRegistrationId + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel + , fieldLabelModifier = camelToPathPiece' 3 + , sumEncoding = TaggedObject "action" "data" + } ''ExamUserCsvAction + +data ExamUserCsvException + = ExamUserCsvExceptionNoMatchingUser + | ExamUserCsvExceptionNoMatchingStudyFeatures + | ExamUserCsvExceptionNoMatchingOccurrence + deriving (Show, Generic, Typeable) + +instance Exception ExamUserCsvException + +embedRenderMessage ''UniWorX ''ExamUserCsvException id + getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - Entity eid Exam{..} <- runDB $ fetchExam tid ssh csh examn - - let - examUsersDBTable = DBTable{..} - where - dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do - E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField - E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree - E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) - E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) - E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) - E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) - E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence - E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId - E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid - return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) - dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) - dbtProj = return - dbtColonnade = dbColonnade $ mconcat - [ colUserNameLink (CourseR tid ssh csh . CUserR) - , colUserMatriclenr - , colField resultStudyField - , colDegreeShort resultStudyDegree - , colFeaturesSemester resultStudyFeatures - , sortable (Just "room") (i18nCell MsgExamRoom) (maybe mempty (cell . toWgt . examOccurrenceRoom . entityVal) . view _userTableOccurrence) - ] - dbtSorting = Map.fromList - [ sortUserNameLink queryUser - , sortUserSurname queryUser - , sortUserDisplayName queryUser - , sortUserMatriclenr queryUser - , sortField queryStudyField - , sortDegreeShort queryStudyDegree - , sortFeaturesSemester queryStudyFeatures - ] - dbtFilter = Map.fromList - [ fltrUserNameEmail queryUser - , fltrUserMatriclenr queryUser - , fltrField queryStudyField - , fltrDegree queryStudyDegree - , fltrFeaturesSemester queryStudyFeatures - ] - dbtFilterUI mPrev = mconcat - [ fltrUserNameEmailUI mPrev - , fltrUserMatriclenrUI mPrev - , fltrFieldUI mPrev - , fltrDegreeUI mPrev - , fltrFeaturesSemesterUI mPrev - ] - dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } - dbtParams = def - dbtIdent :: Text - dbtIdent = "exam-users" - dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv - dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv - <$> view (resultUser . _entityVal . _userSurname) - <*> view (resultUser . _entityVal . _userDisplayName) - <*> view (resultUser . _entityVal . _userMatrikelnummer) - <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) - <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) - <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) - <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceRoom) - dbtCsvDecode = Nothing + (registrationResult, examUsersTable) <- runDB $ do + exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn + bonus <- examBonus exam - examUsersDBTableValidator = def - ((), examUsersTable) <- runDB $ dbTable examUsersDBTableValidator examUsersDBTable + let + allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus + showPasses = numSheetsPasses allBoni /= 0 + showPoints = getSum (numSheetsPoints allBoni) /= 0 + + let + examUsersDBTable = DBTable{..} + where + dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do + E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField + E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree + E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField) + E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse) + E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId) + E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid) + E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence + E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid + return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField) + dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId) + dbtProj = return + dbtColonnade = mconcat $ catMaybes + [ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey) + , pure $ colUserNameLink (CourseR tid ssh csh . CUserR) + , pure colUserMatriclenr + , pure $ colField resultStudyField + , pure $ colDegreeShort resultStudyDegree + , pure $ colFeaturesSemester resultStudyFeatures + , pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence + , guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus + SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPasses) (getSum numSheetsPasses) + , guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do + SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus + SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus + return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints) + ] + dbtSorting = Map.fromList + [ sortUserNameLink queryUser + , sortUserSurname queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , sortField queryStudyField + , sortDegreeShort queryStudyDegree + , sortFeaturesSemester queryStudyFeatures + , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilter = Map.fromList + [ fltrUserNameEmail queryUser + , fltrUserMatriclenr queryUser + , fltrField queryStudyField + , fltrDegree queryStudyDegree + , fltrFeaturesSemester queryStudyFeatures + , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName)) + ] + dbtFilterUI mPrev = mconcat + [ fltrUserNameEmailUI mPrev + , fltrUserMatriclenrUI mPrev + , fltrFieldUI mPrev + , fltrDegreeUI mPrev + , fltrFeaturesSemesterUI mPrev + , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + dbtParams = DBParamsForm + { dbParamsFormMethod = POST + , dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional = \csrf -> do + let + actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData) + actionMap = Map.fromList + [ ( ExamUserDeregister + , pure ExamUserDeregisterData + ) + , ( ExamUserAssignOccurrence + , ExamUserAssignOccurrenceData + <$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing) + ) + ] + (res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf + let formRes = (, mempty) . First . Just <$> res + return (formRes, formWgt) + , dbParamsFormEvaluate = liftHandlerT . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtIdent :: Text + dbtIdent = "exam-users" + dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv + dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv + <$> view (resultUser . _entityVal . _userSurname . to Just) + <*> view (resultUser . _entityVal . _userDisplayName . to Just) + <*> view (resultUser . _entityVal . _userMatrikelnummer) + <*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just) + <*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just) + <*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester) + <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped) + <*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral) + dbtCsvDecode = Just DBTCsvDecode + { dbtCsvRowKey = \csv -> do + uid <- lift $ view _2 <$> guessUser csv + fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid + , dbtCsvComputeActions = \case + DBCsvDiffMissing{dbCsvOldKey} + -> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey + DBCsvDiffNew{dbCsvNewKey = Just _} + -> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys" + DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do + (isPart, uid) <- lift $ guessUser dbCsvNew + if + | isPart -> do + yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew + newFeatures <- lift $ lookupStudyFeatures dbCsvNew + Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse + when (newFeatures /= oldFeatures) $ + yield $ ExamUserCsvSetCourseFieldData cpId newFeatures + | otherwise -> + yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew + DBCsvDiffExisting{..} -> do + newOccurrence <- lift $ lookupOccurrence dbCsvNew + when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $ + yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence + + newFeatures <- lift $ lookupStudyFeatures dbCsvNew + when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do + Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey + yield $ ExamUserCsvSetCourseFieldData cpId newFeatures + , dbtCsvClassifyAction = \case + ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister + ExamUserCsvRegisterData{} -> ExamUserCsvRegister + ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister + ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence + ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField + , dbtCsvCoarsenActionClass = \case + ExamUserCsvCourseRegister -> DBCsvActionNew + ExamUserCsvRegister -> DBCsvActionNew + ExamUserCsvDeregister -> DBCsvActionMissing + _other -> DBCsvActionExisting + , dbtCsvExecuteActions = do + C.mapM_ $ \case + ExamUserCsvCourseRegisterData{..} -> do + now <- liftIO getCurrentTime + insert_ CourseParticipant + { courseParticipantCourse = examCourse + , courseParticipantUser = examUserCsvActUser + , courseParticipantRegistration = now + , courseParticipantField = examUserCsvActCourseField + } + insert_ ExamRegistration + { examRegistrationExam = eid + , examRegistrationUser = examUserCsvActUser + , examRegistrationOccurrence = examUserCsvActOccurrence + , examRegistrationTime = now + } + ExamUserCsvRegisterData{..} -> do + examRegistrationTime <- liftIO getCurrentTime + insert_ ExamRegistration + { examRegistrationExam = eid + , examRegistrationUser = examUserCsvActUser + , examRegistrationOccurrence = examUserCsvActOccurrence + , .. + } + ExamUserCsvAssignOccurrenceData{..} -> + update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ] + ExamUserCsvSetCourseFieldData{..} -> + update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ] + ExamUserCsvDeregisterData{..} -> delete examUserCsvActRegistration + return $ CExamR tid ssh csh examn EUsersR + , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case + ExamUserCsvCourseRegisterData{..} -> do + (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe features <- examUserCsvActCourseField + , ^{studyFeaturesWidget features} + $nothing + , _{MsgCourseStudyFeatureNone} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvRegisterData{..} -> do + (User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvAssignOccurrenceData{..} -> do + occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust + [whamlet| + $newline never + ^{registeredUserName' examUserCsvActRegistration} + $maybe ExamOccurrence{examOccurrenceName} <- occ + \ (#{examOccurrenceName}) + $nothing + \ (_{MsgExamNoOccurrence}) + |] + ExamUserCsvSetCourseFieldData{..} -> do + User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant + [whamlet| + $newline never + ^{nameWidget userDisplayName userSurname} + $maybe features <- examUserCsvActCourseField + , ^{studyFeaturesWidget features} + $nothing + , _{MsgCourseStudyFeatureNone} + |] + ExamUserCsvDeregisterData{..} + -> registeredUserName' examUserCsvActRegistration + , dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure + , dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text + } + where + studyFeaturesWidget :: StudyFeaturesId -> Widget + studyFeaturesWidget featId = do + (StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField) + [whamlet| + $newline never + _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} + |] + + registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget + registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname + where + Entity _ User{..} = view resultUser $ existing ! registration + + guessUser :: ExamUserTableCsv -> DB (Bool, UserId) + guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do + users <- E.select . E.from $ \user -> do + E.where_ . E.and $ catMaybes + [ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation + , (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName + , (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname + ] + let isCourseParticipant = E.exists . E.from $ \courseParticipant -> + E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse + E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId + E.limit 2 + return $ (isCourseParticipant, user E.^. UserId) + case users of + (filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)]) + -> return (isPart, uid) + [(E.Value isPart, E.Value uid)] + -> return (isPart, uid) + _other + -> throwM ExamUserCsvExceptionNoMatchingUser + + lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId) + lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do + occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] [] + case occIds of + [occId] -> return occId + _other -> throwM ExamUserCsvExceptionNoMatchingOccurrence + + lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId) + lookupStudyFeatures csv@ExamUserTableCsv{..} = do + uid <- view _2 <$> guessUser csv + studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do + E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField + E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree + E.where_ . E.and $ catMaybes + [ do + field <- csvEUserField + return . E.or $ catMaybes + [ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field) + , Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field) + , (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field + ] + , do + degree <- csvEUserDegree + return . E.or $ catMaybes + [ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree) + , Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree) + , (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree + ] + , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester + ] + E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid + E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary + E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True + E.limit 2 + return $ studyFeatures E.^. StudyFeaturesId + case studyFeatures of + [E.Value fid] -> return $ Just fid + _other + | is _Nothing csvEUserField + , is _Nothing csvEUserDegree + , is _Nothing csvEUserSemester + -> return Nothing + _other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures + + examUsersDBTableValidator = def + + postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId) + postprocess inp = do + (First (Just act), regMap) <- inp + let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap + return (act, regSet) + over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable + + formResult registrationResult $ \case + (ExamUserDeregisterData, selectedRegistrations) -> do + nrDel <- runDB $ deleteWhereCount + [ ExamRegistrationId <-. Set.toList selectedRegistrations + ] + addMessageI Success $ MsgExamUsersDeregistered nrDel + redirect $ CExamR tid ssh csh examn EUsersR + (ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do + nrUpdated <- runDB $ updateWhereCount + [ ExamRegistrationId <-. Set.toList selectedRegistrations + ] + [ ExamRegistrationOccurrence =. occId + ] + addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated + redirect $ CExamR tid ssh csh examn EUsersR siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading @@ -897,18 +1291,26 @@ postERegisterR tid ssh csh examn = do ((btnResult, _), _) <- runFormPost buttonForm formResult btnResult $ \case - BtnRegister -> do + BtnExamRegister -> do runDB $ do now <- liftIO getCurrentTime insert_ $ ExamRegistration eId uid Nothing now audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageI Success $ MsgExamRegisteredSuccess examn + addMessageWidget Success [whamlet| +

#{iconExamRegister True} +
  +
_{MsgExamRegisteredSuccess examn} + |] redirect $ CExamR tid ssh csh examn EShowR - BtnDeregister -> do + BtnExamDeregister -> do runDB $ do deleteBy $ UniqueExamRegistration eId uid audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent - addMessageI Success $ MsgExamDeregisteredSuccess examn + addMessageWidget Info [whamlet| +
#{iconExamRegister False} +
  +
_{MsgExamDeregisteredSuccess examn} + |] -- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4 redirect $ CExamR tid ssh csh examn EShowR invalidArgs ["Register/Deregister button required"] diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 7103afe14..881ad8eac 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -47,7 +47,7 @@ homeOpenCourses = do let tid = courseTerm course ssh = courseSchool course csh = courseShorthand course - anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) + anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] @@ -130,9 +130,9 @@ homeUpcomingSheets uid = do , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> textCell $ toMessage ssh , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } -> - anchorCell (CourseR tid ssh csh CShowR) (toWidget csh) + anchorCell (CourseR tid ssh csh CShowR) csh , sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } -> - anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget shn) + anchorCell (CSheetR tid ssh csh shn SShowR) shn , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } -> cell $ formatTime SelFormatDateTime deadline >>= toWidget , sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } -> @@ -142,7 +142,7 @@ homeUpcomingSheets uid = do whenM (hasWriteAccessTo submitRoute) $ modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR) - (toWidget $ hasTickmark True) + (hasTickmark True) ] let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"] sheetTable <- liftHandlerT . runDB $ dbTableWidget' validator DBTable @@ -228,18 +228,10 @@ homeUpcomingExams uid = do , sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput } -> do let Entity _ Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput - indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) (toWidget examName) + indicatorCell <> anchorCell (CExamR courseTerm courseSchool courseShorthand examName EShowR) examName , sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom , sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> cell $ do - startT <- formatTime SelFormatDateTime examStart - endT <- traverse (\examEnd' -> formatTime (bool SelFormatDateTime SelFormatTime $ ((==) `on` utctDay) examStart examEnd') examEnd') examEnd - [whamlet| - $newline never - #{startT} - $maybe endT' <- endT - \ – #{endT'} - |] + , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = view lensExam -> Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart {- NOTE: We do not want thoughtless exam registrations, since many people click "register" and don't show up, causing logistic problems. Hence we force them here to click twice. Maybe add a captcha where users have to distinguish pictures showing pink elephants and course lecturers. , sortable Nothing mempty $ \DBRow{ dbrOutput } -> sqlCell $ do @@ -259,7 +251,7 @@ homeUpcomingExams uid = do | otherwise -> return mempty -} , sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput } -> sqlCell $ do - let Entity eId Exam{..} = view lensExam dbrOutput + let Entity eId Exam{..} = view lensExam dbrOutput Entity _ Course{..} = view lensCourse dbrOutput mayRegister <- (== Authorized) <$> evalAccessDB (CExamR courseTerm courseSchool courseShorthand examName ERegisterR) True isRegistered <- existsBy $ UniqueExamRegistration eId uid diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index df31ec398..9c182bb45 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -29,6 +29,7 @@ import qualified Data.Conduit.List as C -- import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E -- import qualified Database.Esqueleto.Internal.Sql as E import Control.Monad.Writer (MonadWriter(..), execWriterT) @@ -122,7 +123,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) <* aformSection MsgSheetFormType <*> sheetTypeAFormReq (fslI MsgSheetType - & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) + & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded])) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction)) @@ -206,7 +207,7 @@ getSheetListR tid ssh csh = do sheetCol = widgetColonnade . mconcat $ [ -- dbRow , sortable (Just "name") (i18nCell MsgSheet) - $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) + $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) @@ -393,7 +394,7 @@ getSShowR tid ssh csh shn = do , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" - , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType + , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> E.orderByEnum $ sheetFile E.^. SheetFileType ) , ( "path" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle @@ -819,7 +820,10 @@ correctorForm shid = wFormToAForm $ do postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) - fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True (Just . Map.fromList . zip [0..] $ Map.toList loads) + filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) + filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! + + fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True filledData getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSCorrR = getSCorrR diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 6dd006d40..cd367b493 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -451,6 +451,8 @@ submissionHelper tid ssh csh shn mcid = do deleteWhere [InvitationFor ==. invRef @SubmissionUser smid, InvitationEmail /<-. subEmails] insertMany_ $ map (flip SubmissionUser smid) subUids sinkInvitationsF submissionUserInvitationConfig $ map (\lEmail -> (lEmail, smid, (InvDBDataSubmissionUser, InvTokenDataSubmissionUser))) subEmails + addMessageI Success $ if | Nothing <- msmid -> MsgSubmissionCreated + | otherwise -> MsgSubmissionUpdated return smid cID <- encrypt smid return $ Just cID diff --git a/src/Handler/SystemMessage.hs b/src/Handler/SystemMessage.hs index 273e33d6d..ae1c7f757 100644 --- a/src/Handler/SystemMessage.hs +++ b/src/Handler/SystemMessage.hs @@ -165,7 +165,7 @@ postMessageListR = do dbtColonnade = mconcat [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId , dbRow - , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . ciphertext) + , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 1f56bcc8d..2f4123a22 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -61,7 +61,7 @@ getCTutorialListR tid ssh csh = do
  • ^{nameEmailWidget' tutor} |] - , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n + , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 27299f655..4bb875d02 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -10,9 +10,11 @@ module Handler.Utils.Csv , ToNamedRecord(..), FromNamedRecord(..) , DefaultOrdered(..) , ToField(..), FromField(..) + , CsvRendered(..) + , toCsvRendered ) where -import Import +import Import hiding (Header) import Data.Csv import Data.Csv.Conduit @@ -21,6 +23,8 @@ import qualified Data.Conduit.List as C import qualified Data.Conduit.Combinators as C (sourceLazy) import qualified Data.Map as Map +import qualified Data.Vector as Vector +import qualified Data.HashMap.Strict as HashMap deriving instance Typeable CsvParseError @@ -69,3 +73,31 @@ fileSourceCsv :: ( FromNamedRecord csv => FileInfo -> Source m csv fileSourceCsv = (.| decodeCsv) . fileSource + + +data CsvRendered = CsvRendered + { csvRenderedHeader :: Header + , csvRenderedData :: [NamedRecord] + } deriving (Eq, Read, Show, Generic, Typeable) + +instance ToWidget UniWorX CsvRendered where + toWidget CsvRendered{..} = liftWidgetT $(widgetFile "widgets/csvRendered") + where + csvData = [ [ decodeUtf8 <$> HashMap.lookup columnKey row + | columnKey <- Vector.toList csvRenderedHeader + ] + | row <- csvRenderedData + ] + + headers = decodeUtf8 <$> Vector.toList csvRenderedHeader + +toCsvRendered :: forall mono. + ( ToNamedRecord (Element mono) + , DefaultOrdered (Element mono) + , MonoFoldable mono + ) + => mono -> CsvRendered +toCsvRendered (otoList -> csvs) = CsvRendered{..} + where + csvRenderedHeader = headerOrder (error "not forced" :: Element mono) + csvRenderedData = map toNamedRecord csvs diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 8297f7266..f0ba27edb 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -3,10 +3,11 @@ module Handler.Utils.DateTime , localTimeToUTC, TZ.LocalToUTCResult(..) , toMidnight, beforeMidnight, toMidday, toMorning , formatDiffDays - , formatTime, formatTime', formatTimeW + , formatTime' + , formatTime, formatTimeW, formatTimeMail + , formatTimeRange, formatTimeRangeW, formatTimeRangeMail , getTimeLocale, getDateTimeFormat , validDateTimeFormats, dateTimeFormatOptions - , formatTimeMail , addOneWeek, addWeeks , weeksToAdd , setYear @@ -236,3 +237,44 @@ ceilingMinuteBy margin roundto utct = addUTCTime bonus utct newMin = roundToNearestMultiple roundto $ oldMin + margin newTime = oldTime { todMin = newMin, todSec = 0 } -- might be invalid, but correctly treated by `timeOfDayToTime` bonus = realToFrac $ timeOfDayToTime newTime - timeOfDayToTime oldTime + + +formatTimeRange' :: ( HasLocalTime t, HasLocalTime t' + , Monad m + ) + => (forall t2. HasLocalTime t2 => SelDateTimeFormat -> t2 -> m Text) -- ^ @formatTime@ + -> SelDateTimeFormat + -> t -- ^ Start + -> Maybe t' -- ^ End + -> m Text +formatTimeRange' cont proj startT endT = do + startT' <- cont proj startT + let + endProj = (/\ proj) $ if + | Just endT' <- endT + , ((==) `on` localDay) (toLocalTime startT) (toLocalTime endT') + -> SelFormatTime + | otherwise + -> SelFormatDateTime + endT' <- for endT $ cont endProj + + return $ case endT' of + Nothing -> startT' + Just endT'' -> [st|#{startT'} – #{endT''}|] + + +formatTimeRange :: ( HasLocalTime t, HasLocalTime t' + , MonadHandler m + , HandlerSite m ~ UniWorX + ) + => SelDateTimeFormat + -> t -- ^ Start + -> Maybe t' -- ^ End + -> m Text +formatTimeRange = formatTimeRange' formatTime + +formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget +formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t' + +formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text +formatTimeRangeMail = formatTimeRange' formatTimeMail diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 3d1d43845..3f53325a8 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,17 +1,23 @@ module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam + , examBonus, examBonusPossible, examBonusAchieved ) where import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Sql as E import Database.Esqueleto.Utils.TH import Utils.Lens +import qualified Data.Conduit.List as C + +import qualified Data.Map as Map + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -45,3 +51,35 @@ fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutoria fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam) fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn + + +examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary) +examBonus (Entity eId Exam{..}) = runConduit $ + let + rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do + E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId) + E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser + E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId + ) + E.on E.true + E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId + E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse + E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.where_ $ E.case_ + [ E.when_ + ( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence ) + E.then_ + ( E.just (sheet E.^. SheetActiveTo) E.<=. examOccurrence E.?. ExamOccurrenceStart + E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart + ) + ] + ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom + ) + return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission) + accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) -> + Map.unionWith mappend acc . Map.singleton uid . sheetTypeSum sheetType . (>>= submissionRatingPoints) $ assertM submissionRatingDone sub + in rawData .| accum + +examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> Maybe SheetGradeSummary +examBonusPossible uid bonusMap = normalSummary <$> Map.lookup uid bonusMap +examBonusAchieved uid bonusMap = (mappend <$> normalSummary <*> bonusSummary) <$> Map.lookup uid bonusMap diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 58ea2ffaf..b7548543c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -463,8 +463,8 @@ classifyBonusRule = \case ExamNoBonus -> ExamNoBonus' ExamBonusPoints{} -> ExamBonusPoints' -bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule -bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev +examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule +examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev where actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) actions = Map.fromList @@ -681,7 +681,7 @@ nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'") embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>) -data SheetType' = NotGraded' | Normal' | Bonus' | Informational' +data SheetType' = Normal' | Bonus' | Informational' | NotGraded' deriving (Eq, Ord, Read, Show, Enum, Bounded) instance Universe SheetType' @@ -913,6 +913,16 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs +examOccurrenceField :: ( MonadHandler m + , HandlerSite m ~ UniWorX + ) + => ExamId + -> Field m ExamOccurrenceId +examOccurrenceField eid + = hoistField liftHandlerT . selectField . (fmap $ fmap entityKey) + $ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName + + formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m () formResultModal res finalDest handler = maybeT_ $ do messages <- case res of diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index ae87527bf..c8a869514 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -21,8 +21,6 @@ import Utils.Lens import Handler.Utils.Form.MassInput.Liveliness import Handler.Utils.Form.MassInput.TH -import Algebra.Lattice hiding (join) - import Text.Blaze (Markup) import qualified Data.Text as Text diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 812c2ff66..345f8a4b1 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -491,17 +491,20 @@ sinkSubmission userId mExists isUpdate = do alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating when alreadySeen $ throwM DuplicateRating - Submission{..} <- lift $ getJust submissionId + submission <- lift $ getJust submissionId now <- liftIO getCurrentTime let - rated = submissionRatingBy == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files - r' = let Rating'{..} = r - in Rating' - { ratingTime = now <$ guard rated - , .. - } - let Rating'{..} = r' + rated = submissionRatingBy submission == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files + r'@Rating'{..} = r + { ratingTime = now <$ guard rated -- Ignore `ratingTime` from result @r@ of `parseRating` to ensure plausible timestamps (`parseRating` returns file modification time for consistency with `ratingFile`) + } + submission' = submission + { submissionRatingPoints = ratingPoints + , submissionRatingComment = ratingComment + , submissionRatingTime = ratingTime + , submissionRatingBy = userId <$ guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) + } tellSt $ mempty{ sinkSeenRating = Last $ Just r' } unless isUpdate $ throwM RatingWithoutUpdate @@ -510,25 +513,23 @@ sinkSubmission userId mExists isUpdate = do -- -- 'fileModified' is simply stored and never inspected while -- 'submissionChanged' is always set to @now@. - let anyChanges = or $ - [ submissionRatingPoints /= ratingPoints - , submissionRatingComment /= ratingComment + let anyChanges = any (\f -> f submission submission') $ + [ (/=) `on` submissionRatingPoints + , (/=) `on` submissionRatingComment + , (/=) `on` submissionRatingDone + , (/=) `on` submissionRatingBy ] when anyChanges $ do touchSubmission - Sheet{..} <- lift $ getJust submissionSheet + Sheet{..} <- lift . getJust $ submissionSheet submission' mapM_ throwM $ validateRating sheetType r' - when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } - lift $ update submissionId - [ SubmissionRatingPoints =. ratingPoints - , SubmissionRatingComment =. ratingComment - , SubmissionRatingTime =. ratingTime - , SubmissionRatingBy =. (userId <$ guard rated) -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) - ] + when (submissionRatingDone submission' && not (submissionRatingDone submission)) $ + tellSt mempty { sinkSubmissionNotifyRating = Any True } + lift $ replace submissionId submission' where a /~ b = not $ a ~~ b diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index df62bbdbb..948febc54 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -91,7 +91,7 @@ ifCell decision cTrue cFalse x | otherwise = cFalse x linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a -linkEmptyCell link wgt = linkEitherCell link (wgt,mempty) +linkEmptyCell = anchorCell msgCell :: (ToMessage t, IsDBTable m a) => t -> DBCell m a msgCell = textCell . toMessage @@ -123,7 +123,7 @@ isNewCell = cell . toWidget . isNew commentCell :: IsDBTable m a => Maybe (Route UniWorX) -> DBCell m a commentCell Nothing = mempty commentCell (Just link) = anchorCell link icon - where icon = toWidget $ hasComment True + where icon = hasComment True -- | whether something is visible or hidden isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a @@ -134,11 +134,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass -- | for simple file downloads fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a -fileCell route = anchorCell route $ toWidget fileDownload +fileCell route = anchorCell route fileDownload -- | for zip-archive downloads zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a -zipCell route = anchorCell route $ toWidget zipDownload +zipCell route = anchorCell route zipDownload -- | Display an icon that opens a modal upon clicking modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a @@ -214,6 +214,9 @@ maybeDateTimeCell = maybe mempty dateTimeCell numCell :: (IsDBTable m a, Num b, ToMessage b) => b -> DBCell m a numCell = textCell . toMessage +propCell :: (IsDBTable m a, Real b, ToMessage b) => b -> b -> DBCell m a +propCell curr max' = i18nCell $ MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + int64Cell :: (IsDBTable m a) => Int64-> DBCell m a int64Cell = numCell diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 8bc074b2e..7384a0c5c 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -6,7 +6,10 @@ module Handler.Utils.Table.Pagination , FilterColumn(..), IsFilterColumn , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount , DBStyle(..), defaultDBSFilterLayout, DBEmptyStyle(..) - , DBTCsvEncode, DBTCsvDecode + , module Handler.Utils.Table.Pagination.CsvColumnExplanations + , DBCsvActionMode(..) + , DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew + , DBTCsvEncode, DBTCsvDecode(..) , DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..) , singletonFilter , DBParams(..) @@ -35,6 +38,7 @@ module Handler.Utils.Table.Pagination ) where import Handler.Utils.Table.Pagination.Types +import Handler.Utils.Table.Pagination.CsvColumnExplanations import Handler.Utils.Form import Handler.Utils.Csv import Handler.Utils.ContentDisposition @@ -49,23 +53,28 @@ import qualified Database.Esqueleto.Internal.Language as E (From) import qualified Network.Wai as Wai -import Control.Monad.RWS hiding ((<>), mapM_) -import Control.Monad.Writer hiding ((<>), mapM_) +import Control.Monad.RWS (RWST(..), execRWS) +import Control.Monad.Writer (WriterT(..)) import Control.Monad.Reader (ReaderT(..), mapReaderT) +import Control.Monad.State (StateT(..), evalStateT) import Control.Monad.Trans.Maybe +import Control.Monad.State.Class (modify) +import qualified Control.Monad.State.Class as State import Data.Foldable (Foldable(foldMap)) -import Data.Map (Map) +import Data.Map (Map, (!)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI +import Data.Csv (NamedRecord) + import Colonnade hiding (bool, fromMaybe, singleton) import qualified Colonnade (singleton) -import Colonnade.Encode +import Colonnade.Encode hiding (row) import Text.Hamlet (hamletFile) @@ -96,6 +105,7 @@ import Data.Semigroup as Sem (Semigroup(..)) import qualified Data.Conduit.List as C import Handler.Utils.DateTime (formatTimeW) +import qualified Control.Monad.Catch as Catch #if MIN_VERSION_base(4,11,0) @@ -271,8 +281,19 @@ piIsUnset PaginationInput{..} = and , isNothing piPage ] + +data DBCsvActionMode = DBCsvActionNew | DBCsvActionExisting | DBCsvActionMissing + deriving (Read, Show, Eq, Ord, Enum, Bounded, Generic, Typeable) +instance Universe DBCsvActionMode +instance Finite DBCsvActionMode -data ButtonCsvMode = BtnCsvExport | BtnCsvImport +nullaryPathPiece ''DBCsvActionMode $ camelToPathPiece' 3 +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 3 + } ''DBCsvActionMode + + +data ButtonCsvMode = BtnCsvExport | BtnCsvImport | BtnCsvImportConfirm deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCsvMode instance Finite ButtonCsvMode @@ -288,21 +309,51 @@ instance Button UniWorX ButtonCsvMode where #{iconCSV} \ _{BtnCsvExport} |] - btnLabel BtnCsvImport - = [whamlet| - $newline never - _{BtnCsvImport} - |] - -data DBCsvMode = DBCsvNormal - | DBCsvExport - | DBCsvImport - { _dbCsvFiles :: [FileInfo] - , _dbCsvModifyExisting, _dbCsvAddNew, _dbCsvDeleteMissing :: Bool - } + btnLabel x = [whamlet|_{x}|] -type DBTableKey k' = (ToJSON k', FromJSON k', Ord k', Binary k') +data DBCsvMode + = DBCsvNormal + | DBCsvExport + | DBCsvImport + { dbCsvFiles :: [FileInfo] + } + +data DBCsvDiff r' csv k' + = DBCsvDiffNew + { dbCsvNewKey :: Maybe k' + , dbCsvNew :: csv + } + | DBCsvDiffExisting + { dbCsvOldKey :: k' + , dbCsvOld :: r' + , dbCsvNew :: csv + } + | DBCsvDiffMissing + { dbCsvOldKey :: k' + , dbCsvOld :: r' + } + +makeLenses_ ''DBCsvDiff +makePrisms ''DBCsvDiff + +data DBCsvException k' + = DBCsvDuplicateKey + { dbCsvDuplicateKey :: k' + , dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB :: NamedRecord + } + | DBCsvException + { dbCsvExceptionRow :: NamedRecord + , dbCsvException :: Text + } + deriving (Show, Typeable) + +makeLenses_ ''DBCsvException + +instance (Typeable k', Show k') => Exception (DBCsvException k') + + +type DBTableKey k' = (Show k', ToJSON k', FromJSON k', Ord k', Binary k', Typeable k') data DBRow r = forall k'. DBTableKey k' => DBRow { dbrKey :: k' , dbrOutput :: r @@ -444,9 +495,25 @@ instance PathPiece x => PathPiece (WithIdent x) where (ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt WithIdent <$> pure ident <*> fromPathPiece rest - -type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv) (Conduit r' (YesodDB UniWorX) csv) -type DBTCsvDecode csv = DictMaybe (FromNamedRecord csv) (Sink csv (YesodDB UniWorX) ()) +type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv) +data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException. + ( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv + , DBTableKey k' + , RedirectUrl UniWorX route + , Typeable csv + , Ord csvAction, FromJSON csvAction, ToJSON csvAction + , Ord csvActionClass + , Exception csvException + ) => DBTCsvDecode + { dbtCsvRowKey :: csv -> MaybeT (YesodDB UniWorX) k' + , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> Source (YesodDB UniWorX) csvAction + , dbtCsvClassifyAction :: csvAction -> csvActionClass + , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode + , dbtCsvExecuteActions :: Sink csvAction (YesodDB UniWorX) route + , dbtCsvRenderKey :: Map k' r' -> csvAction -> Widget + , dbtCsvRenderActionClass :: csvActionClass -> Widget + , dbtCsvRenderException :: csvException -> YesodDB UniWorX Text + } data DBTable m x = forall a r r' h i t k k' csv. ( ToSortable h, Functor h @@ -464,11 +531,11 @@ data DBTable m x = forall a r r' h i t k k' csv. , dbtStyle :: DBStyle r' , dbtParams :: DBParams m x , dbtCsvEncode :: DBTCsvEncode r' csv - , dbtCsvDecode :: DBTCsvDecode csv + , dbtCsvDecode :: Maybe (DBTCsvDecode r' k' csv) , dbtIdent :: i } -noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void) (Conduit r' (YesodDB UniWorX) Void) +noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void) noCsvEncode = Nothing class (MonadHandler m, HandlerSite m ~ UniWorX, Monoid' x, Monoid' (DBCell m x), Default (DBParams m x)) => IsDBTable (m :: * -> *) (x :: *) where @@ -760,9 +827,6 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db ((csvExportRes, csvExportWdgt), csvExportEnctype) <- lift . runFormGet . identifyForm FIDDBTableCsvExport . set (mapped . mapped . _1 . mapped) DBCsvExport $ buttonForm' [BtnCsvExport] ((csvImportRes, csvImportWdgt), csvImportEnctype) <- lift . runFormPost . identifyForm FIDDBTableCsvImport . renderAForm FormDBTableCsvImport $ DBCsvImport <$> areq fileFieldMultiple (fslI MsgCsvFile) Nothing - <*> apopt checkBoxField (fslI MsgCsvModifyExisting) (Just True) - <*> apopt checkBoxField (fslI MsgCsvAddNew) (Just True) - <*> apopt checkBoxField (fslI MsgCsvDeleteMissing) (Just False) let csvMode = asum @@ -774,7 +838,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db { formMethod = GET , formAction = Just $ tblLink id , formEncoding = csvExportEnctype - , formAttrs = [("target", "_blank")] + , formAttrs = [("target", "_blank"), ("class", "form--inline")] , formSubmit = FormNoSubmit , formAnchor = Nothing :: Maybe Text } @@ -786,6 +850,12 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db , formSubmit = FormSubmit , formAnchor = Nothing :: Maybe Text } + csvColExplanations = case dbtCsvEncode of + (Just (Dict, _) :: DBTCsvEncode _ csv) -> assertM' (not . null) . Map.toList . csvColumnsExplanations $ Proxy @csv + Nothing -> Nothing + csvColExplanations' = case csvColExplanations of + Just csvColExplanations'' -> modal [whamlet|_{MsgCsvColumnsExplanationsLabel}|] $ Right $(widgetFile "table/csv-column-explanations") + Nothing -> mempty rows' <- E.select . E.from $ \t -> do @@ -824,13 +894,127 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db formResult csvMode $ \case DBCsvExport - | Just (Dict, dbtCsvEncode') <- dbtCsvEncode - -> do - setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv - sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode' - DBCsvImport{} - | Just (Dict, _dbtCsvDecode) <- dbtCsvDecode - -> error "dbCsvImport" + | Just (Dict, dbtCsvEncode') <- dbtCsvEncode -> do + setContentDisposition' . Just $ unpack dbtIdent <.> unpack extensionCsv + sendResponse <=< liftHandlerT . respondCsvDB $ C.sourceList rows .| dbtCsvEncode' + DBCsvImport{..} + | Just (DBTCsvDecode{ dbtCsvClassifyAction = dbtCsvClassifyAction :: csvAction -> csvActionClass + , .. + } :: DBTCsvDecode r' k' csv) <- dbtCsvDecode -> do + let existing = Map.fromList $ zip currentKeys rows + sourceDiff :: Source (StateT (Map k' csv) (YesodDB UniWorX)) (DBCsvDiff r' csv k') + sourceDiff = do + let + toDiff :: csv -> StateT (Map k' csv) (YesodDB UniWorX) (DBCsvDiff r' csv k') + toDiff row = do + rowKey <- lift $ + handle (throwM . (DBCsvException (toNamedRecord row) :: Text -> DBCsvException k') <=< dbtCsvRenderException) . runMaybeT $ dbtCsvRowKey row + seenKeys <- State.get + (<* modify (maybe id (flip Map.insert row) rowKey)) $ if + | Just rowKey' <- rowKey + , Just oldRow <- Map.lookup rowKey' seenKeys + -> throwM $ DBCsvDuplicateKey rowKey' (toNamedRecord oldRow) (toNamedRecord row) + | Just rowKey' <- rowKey + , Just oldRow <- Map.lookup rowKey' existing + -> return $ DBCsvDiffExisting rowKey' oldRow row + | otherwise + -> return $ DBCsvDiffNew rowKey row + mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff + + seen <- State.get + forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if + | Map.member rowKey seen -> return () + | otherwise -> yield $ DBCsvDiffMissing rowKey oldRow + + accActionMap :: Map csvActionClass (Set csvAction) -> csvAction -> Map csvActionClass (Set csvAction) + accActionMap acc csvAct = Map.insertWith Set.union (dbtCsvClassifyAction csvAct) (Set.singleton csvAct) acc + + importCsv = do + let + dbtCsvComputeActions' :: Sink (DBCsvDiff r' csv k') (YesodDB UniWorX) (Map csvActionClass (Set csvAction)) + dbtCsvComputeActions' = do + let innerAct = awaitForever $ \x + -> let doHandle + | Just inpCsv <- x ^? _dbCsvNew + = handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException + | otherwise + = id + in yieldM . doHandle . runConduit $ dbtCsvComputeActions x .| C.fold accActionMap Map.empty + innerAct .| C.foldMap id + actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions' + + when (Map.null actionMap) $ do + addMessageI Info MsgCsvImportUnnecessary + redirect $ tblLink id + + liftHandlerT . (>>= sendResponse) $ + siteLayoutMsg MsgCsvImportConfirmationHeading $ do + setTitleI MsgCsvImportConfirmationHeading + + let + precomputeIdents :: forall f m'. (Eq (Element f), MonoFoldable f, MonadHandler m') => f -> m' (Element f -> Text) + precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed") + actionClassIdent <- precomputeIdents $ Map.keys actionMap + actionIdent <- precomputeIdents . Set.unions $ Map.elems actionMap + + let defaultChecked actClass = case dbtCsvCoarsenActionClass actClass of + DBCsvActionMissing -> False + _other -> True + csvActionCheckBox :: [(Text, Text)] -> csvAction -> Widget + csvActionCheckBox vAttrs act = do + let + sJsonField :: Field (HandlerT UniWorX IO) csvAction + sJsonField = secretJsonField' $ \theId name attrs val _isReq -> + [whamlet| + $newline never + + |] + fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False + (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandlerT . generateFormPost . identifyForm FIDDBTableCsvImportConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation")) + let csvImportConfirmForm = wrapForm' BtnCsvImportConfirm csvImportConfirmForm' FormSettings + { formMethod = POST + , formAction = Just $ tblLink id + , formEncoding = csvImportConfirmEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Nothing :: Maybe Text + } + + $(widgetFile "csv-import-confirmation-wrapper") + + let defaultHeaderOrder = headerOrder (error "not to be forced" :: csv) + catches importCsv + [ Catch.Handler $ \case + (DBCsvDuplicateKey{..} :: DBCsvException k') + -> liftHandlerT $ sendResponseStatus badRequest400 =<< do + mr <- getMessageRender + + let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvDuplicateKeyRowA, dbCsvDuplicateKeyRowB ] + heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvDuplicateKey] + + siteLayoutMsg heading $ do + setTitleI heading + [whamlet| +

    _{MsgDBCsvDuplicateKey} +

    _{MsgDBCsvDuplicateKeyTip} + ^{offendingCsv} + |] + (DBCsvException{..} :: DBCsvException k') + -> liftHandlerT $ sendResponseStatus badRequest400 =<< do + mr <- getMessageRender + + let offendingCsv = CsvRendered defaultHeaderOrder [ dbCsvExceptionRow ] + heading = ErrorResponseTitle $ InvalidArgs [mr MsgDBCsvException] + + siteLayoutMsg heading $ do + setTitleI heading + [whamlet| +

    _{MsgDBCsvException} + $if not (Text.null dbCsvException) +

    #{dbCsvException} + ^{ offendingCsv} + |] + ] _other -> return () let @@ -903,7 +1087,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db csvWdgt = $(widgetFile "table/csv-transcode") - uiLayout table = dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout") + uiLayout table = csvWdgt <> dbsFilterLayout filterWdgt filterEnc (SomeRoute $ rawAction :#: wIdent "table-wrapper") $(widgetFile "table/layout") dbInvalidateResult' = foldr (<=<) return . catMaybes $ [ do @@ -912,6 +1096,22 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db return . dbInvalidateResult dbtParams . DBTIRowsMissing $ length previousKeys - length currentKeys ] + ((csvImportConfirmRes, ()), _enctype) <- case dbtCsvDecode of + Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do + lift . runFormPost . identifyForm FIDDBTableCsvImportConfirm $ \_csrf -> do + acts <- globalPostParamFields PostDBCsvImportAction secretJsonField + return . (, ()) $ if + | null acts -> FormSuccess $ do + addMessageI Info MsgCsvImportAborted + redirect $ tblLink id + | otherwise -> FormSuccess $ do + finalDest <- runConduit $ C.sourceList acts .| dbtCsvExecuteActions + addMessageI Success . MsgCsvImportSuccessful $ length acts + E.transactionSave + redirect finalDest + _other -> return ((FormMissing, ()), mempty) + formResult csvImportConfirmRes id + dbInvalidateResult' <=< bool (dbHandler (Proxy @m) (Proxy @x) $ (\table -> $(widgetFile "table/layout-wrapper")) . uiLayout) (sendResponse <=< tblLayout . uiLayout <=< dbWidget (Proxy @m) (Proxy @x)) psShortcircuit <=< runDBTable dbtable paginationInput currentKeys . fmap swap $ runWriterT table' where tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html @@ -993,43 +1193,47 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt) -- | Always display widget; maybe a link if user is Authorized. -- Also see variant `linkEmptyCell` -anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a +anchorCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a) => url -> wgt -> DBCell m a anchorCell = anchorCellM . return -{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-} -anchorCell' :: IsDBTable m a - => (r -> Route UniWorX) - -> (r -> Widget) +anchorCell' :: ( IsDBTable m a + , ToWidget UniWorX wgt + , HasRoute UniWorX url + ) + => (r -> url) + -> (r -> wgt) -> (r -> DBCell m a) anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val) -anchorCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a +anchorCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> wgt -> DBCell m a anchorCellM routeM widget = anchorCellM' routeM id (const widget) -anchorCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a -anchorCellM' xM x2route x2widget = cell $ do - x <- xM - let route = x2route x - widget = x2widget x - authResult <- liftHandlerT $ isAuthorized route False - case authResult of - Authorized -> $(widgetFile "table/cell/link") -- show allowed link - _otherwise -> widget -- don't show prohibited link +anchorCellM' :: (HasRoute UniWorX url, ToWidget UniWorX wgt, IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt) -> DBCell m a +anchorCellM' xM x2route x2widget = linkEitherCellM' xM x2route (x2widget, x2widget) -- | Variant of `anchorCell` that displays different widgets depending whether the route is authorized for current user -linkEitherCell :: IsDBTable m a => Route UniWorX -> (Widget, Widget) -> DBCell m a +linkEitherCell :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => url -> (wgt, wgt') -> DBCell m a linkEitherCell = linkEitherCellM . return -linkEitherCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> (Widget, Widget) -> DBCell m a +linkEitherCellM :: (HasRoute UniWorX url, ToWidget UniWorX wgt, ToWidget UniWorX wgt', IsDBTable m a, HandlerSite m ~ UniWorX) => WidgetT UniWorX IO url -> (wgt, wgt') -> DBCell m a linkEitherCellM routeM (widgetAuth,widgetUnauth) = linkEitherCellM' routeM id (const widgetAuth, const widgetUnauth) -linkEitherCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget, x -> Widget) -> DBCell m a +linkEitherCellM' :: forall m url wgt wgt' a x. + ( HasRoute UniWorX url + , ToWidget UniWorX wgt + , ToWidget UniWorX wgt' + , IsDBTable m a + , HandlerSite m ~ UniWorX + ) + => WidgetT UniWorX IO x -> (x -> url) -> (x -> wgt, x -> wgt') -> DBCell m a linkEitherCellM' xM x2route (x2widgetAuth,x2widgetUnauth) = cell $ do x <- xM let route = x2route x - widget = x2widgetAuth x - widgetUnauth = x2widgetUnauth x - authResult <- liftHandlerT $ isAuthorized route False + widget, widgetUnauth :: WidgetT UniWorX IO () + widget = toWidget $ x2widgetAuth x + widgetUnauth = toWidget $ x2widgetUnauth x + authResult <- liftHandlerT $ isAuthorized (urlRoute route) False + linkUrl <- toTextUrl route case authResult of Authorized -> $(widgetFile "table/cell/link") -- show allowed link _otherwise -> widgetUnauth -- show alternative widget diff --git a/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs b/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs new file mode 100644 index 000000000..460a9414b --- /dev/null +++ b/src/Handler/Utils/Table/Pagination/CsvColumnExplanations.hs @@ -0,0 +1,70 @@ +module Handler.Utils.Table.Pagination.CsvColumnExplanations + ( CsvColumnsExplained(..) + , genericCsvColumnsExplanations + ) where + +import Import + +import qualified Data.Csv as Csv +import GHC.Generics +import qualified GHC.Generics as Generics + +import Language.Haskell.TH +-- import Language.Haskell.TH.Datatype +-- import Language.Haskell.TH.Lib + +import qualified Data.Map as Map +import qualified Data.ByteString.Char8 as B8 + + +class CsvColumnsExplained csv where + csvColumnsExplanations :: forall p. p csv -> Map Csv.Name Widget + csvColumnsExplanations _ = Map.empty + +genericCsvColumnsExplanations :: forall msg p csv. + ( Generic csv + , GCsvColumnsExplained (Rep csv) + , RenderMessage UniWorX msg + ) + => Csv.Options + -> Map Name msg + -> p csv + -> Map Csv.Name Widget +genericCsvColumnsExplanations opts msgMap' _ = Map.mapMaybe (fmap (toWidget <=< ap getMessageRender . pure) . flip Map.lookup msgMap) headerNames + where + msgMap :: Map String msg + msgMap = Map.mapKeys nameBase msgMap' + headerNames :: Map Csv.Name String + headerNames = gCsvColumnsExplanations opts $ Generics.from (error "proxy" :: csv) + +class GCsvColumnsExplained a where + gCsvColumnsExplanations :: Csv.Options -> a p -> Map Csv.Name String + +instance GCsvColumnsExplained U1 where + gCsvColumnsExplanations _ _ = Map.empty + +instance (GCsvColumnsExplained a, GCsvColumnsExplained b) => GCsvColumnsExplained (a :*: b) where + gCsvColumnsExplanations opts _ = Map.unionWithKey (\h f1 f2 -> error $ "Column header ‘" ++ B8.unpack h ++ "’ is produced by both ‘" ++ f1 ++ "’ and ‘" ++ f2 ++ "’") + (gCsvColumnsExplanations opts (error "proxy" :: a p)) + (gCsvColumnsExplanations opts (error "proxy" :: b p)) + + +instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 D c a) where + gCsvColumnsExplanations opts _ = gCsvColumnsExplanations opts (error "proxy" :: a p) + +instance GCsvColumnsExplained a => GCsvColumnsExplained (M1 C c a) where + gCsvColumnsExplanations opts _ = gCsvColumnsExplanations opts (error "proxy" :: a p) + +-- | Instance to ensure that you cannot derive DefaultOrdered for +-- constructors without selectors. +instance CsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a ()) + => GCsvColumnsExplained (M1 S ('MetaSel 'Nothing srcpk srcstr decstr) a) + where + gCsvColumnsExplanations _ _ = + error "You cannot derive CsvColumnsExplanations for constructors without selectors." + +instance Selector s => GCsvColumnsExplained (M1 S s a) where + gCsvColumnsExplanations (Csv.fieldLabelModifier -> f) m + | null name = error "Cannot derive CsvColumnsExplanations for constructors without selectors" + | otherwise = Map.singleton (B8.pack $ f name) name + where name = selName m diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index bb7c5dd78..cd1bd66c2 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -77,6 +77,8 @@ import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), To import Data.Constraint as Import (Dict(..)) import Data.Void as Import (Void) +import Algebra.Lattice as Import hiding (meet, join) + import Language.Haskell.TH.Instances as Import () import Data.List.NonEmpty.Instances as Import () import Data.NonNull.Instances as Import () diff --git a/src/Jobs/Handler/SendNotification/SubmissionRated.hs b/src/Jobs/Handler/SendNotification/SubmissionRated.hs index 75314e786..ff9a45f5a 100644 --- a/src/Jobs/Handler/SendNotification/SubmissionRated.hs +++ b/src/Jobs/Handler/SendNotification/SubmissionRated.hs @@ -7,8 +7,7 @@ module Jobs.Handler.SendNotification.SubmissionRated import Import import Utils.Lens -import Handler.Utils.DateTime -import Handler.Utils.Mail +import Handler.Utils import Jobs.Handler.SendNotification.Utils import Text.Hamlet @@ -23,6 +22,9 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien course <- belongsToJust sheetCourse sheet corrector <- traverse getJust submissionRatingBy return (course, sheet, submission, corrector) + + whenIsJust corrector $ \corrector' -> + addMailHeader "Reply-To" . renderAddress $ userAddress corrector' replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand @@ -45,7 +47,13 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien , "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints) , "submission-rating-comment" Aeson..= submissionRatingComment , "submission-rating-time" Aeson..= submissionRatingTime - , "submission-rating-by" Aeson..= (userDisplayName <$> corrector) + , (Aeson..=) "submission-rating-by" $ do + corrector' <- corrector + return $ Aeson.object + [ "display-name" Aeson..= userDisplayName corrector' + , "surname" Aeson..= userSurname corrector' + , "email" Aeson..= userEmail corrector' + ] , "submission-rating-passed" Aeson..= join (gradingPassed <$> sheetType ^? _grading <*> submissionRatingPoints) , "sheet-name" Aeson..= sheetName , "sheet-type" Aeson..= sheetType diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index e24c93de3..755434aa3 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -28,6 +28,8 @@ import Control.Monad.Trans.Reader (mapReaderT) import Control.Monad.Except (MonadError(..)) import Utils (exceptT) +import Numeric.Natural + -- Database versions must follow https://pvp.haskell.org: -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table) @@ -57,7 +59,11 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"] deriving Show Eq Ord |] -migrateAll :: (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m () +migrateAll :: ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + ) + => ReaderT SqlBackend m () migrateAll = do $logDebugS "Migration" "Initial migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent initialMigration @@ -77,14 +83,19 @@ migrateAll = do $logDebugS "Migration" "Persistent automatic migration" mapM_ ($logInfoS "Migration") =<< runMigrationSilent migrateAll' -requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool +requiresMigration :: forall m. + ( MonadLogger m + , MonadBaseControl IO m + , MonadIO m + ) + => ReaderT SqlBackend m Bool requiresMigration = mapReaderT (exceptT return return) $ do initial <- either id (map snd) <$> parseMigration initialMigration when (not $ null initial) $ do $logInfoS "Migration" $ intercalate "; " initial throwError True - customs <- getMissingMigrations @_ @m + customs <- mapReaderT lift $ getMissingMigrations @_ @m when (not $ Map.null customs) $ do $logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs throwError True @@ -123,7 +134,8 @@ getMissingMigrations = do -} -customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) +customMigrations :: ( MonadIO m + ) => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations = Map.fromListWith (>>) [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|] , whenM (columnExists "user" "theme") $ do -- New theme format @@ -292,6 +304,20 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "exam") $ -- Exams were an unused stub before tableDropEmpty "exam" ) + , ( AppliedMigrationKey [migrationVersion|13.0.0|] [version|14.0.0|] + , whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do + examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |] + [executeQQ| + ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null; + |] + forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do + let name = [st|occ-#{tshow n}|] + [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |] + [executeQQ| + ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT; + ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL; + |] + ) ] diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index e5ed53362..2126ce178 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -1,4 +1,4 @@ -module Model.Migration.Types where +module Model.Migration.Types where import ClassyPrelude.Yesod import Data.Aeson @@ -13,8 +13,8 @@ import Data.Universe data SheetType - = Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben - | Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben + = Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben + | Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben | Pass { maxPoints, passingPoints :: Current.Points } | NotGraded deriving (Show, Read, Eq) @@ -58,7 +58,7 @@ instance Finite SheetSubmissionMode nullaryPathPiece ''SheetSubmissionMode camelToPathPiece - + {- TODO: * RenderMessage instance for newtype(SheetType) if needed -} diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index c0cd4a30b..2d8e8b1d0 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -16,19 +16,20 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore type Count = Sum Integer type Points = Centi -type Email = Text +type Email = Text -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type UserIdent = CI Text -type TutorialName = CI Text -type ExamName = CI Text -type ExamPartName = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type SheetName = CI Text +type MaterialName = CI Text +type UserEmail = CI Email +type UserIdent = CI Text +type TutorialName = CI Text +type ExamName = CI Text +type ExamPartName = CI Text +type ExamOccurrenceName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index b4a6b0a90..4a6c60a32 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -12,6 +12,7 @@ import Model.Types.Common import Utils.Lens.TH import Control.Lens +import Control.Lens.Extras (is) import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Set (Set) @@ -40,6 +41,7 @@ deriveJSON defaultOptions derivePersistFieldJSON ''SheetGrading makeLenses_ ''SheetGrading +makePrisms ''SheetGrading _passingBound :: Fold SheetGrading (Either () Points) _passingBound = folding passPts @@ -57,17 +59,22 @@ gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound data SheetGradeSummary = SheetGradeSummary { numSheets :: Count -- Total number of sheets, includes all - , numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses - , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPasses :: Count -- Number of sheets admitting passing FKA: numGradePasses + , numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd + , numSheetsPassPoints :: Count -- Number of sheets where passing is by points , sumSheetsPoints :: Sum Points -- Total of all points in all sheets + , sumSheetsPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- Marking dependend , numMarked :: Count -- Number of already marked sheets , numMarkedPasses :: Count -- Number of already marked sheets with passes , numMarkedPoints :: Count -- Number of already marked sheets with points + , numMarkedPassPoints :: Count -- Number of already marked sheets where passing is by points , sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets + , sumMarkedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points -- , achievedPasses :: Count -- Achieved passes (within marked sheets) , achievedPoints :: Sum Points -- Achieved points (within marked sheets) + , achievedPassPoints :: Sum Points -- Achieved points within marked sheets where passing is by points } deriving (Generic, Read, Show, Eq) instance Monoid SheetGradeSummary where @@ -82,19 +89,24 @@ makeLenses_ ''SheetGradeSummary sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary sheetGradeSum gr Nothing = mempty { numSheets = 1 - , numSheetsPasses = bool mempty 1 $ has _passingBound gr - , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPasses = bool mempty 1 $ has _passingBound gr + , numSheetsPoints = bool mempty 1 $ has _maxPoints gr + , numSheetsPassPoints = bool mempty 1 $ is _PassPoints gr , sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints + , sumSheetsPassPoints = maybe mempty Sum . (<* guard (is _PassPoints gr)) $ gr ^? _maxPoints } sheetGradeSum gr (Just p) = let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing in unmarked - { numMarked = numSheets - , numMarkedPasses = numSheetsPasses - , numMarkedPoints = numSheetsPoints - , sumMarkedPoints = sumSheetsPoints + { numMarked = numSheets + , numMarkedPasses = numSheetsPasses + , numMarkedPoints = numSheetsPoints + , numMarkedPassPoints = numSheetsPassPoints + , sumMarkedPoints = sumSheetsPoints + , sumMarkedPassPoints = sumSheetsPassPoints , achievedPasses = maybe mempty (bool 0 1) (gradingPassed gr p) , achievedPoints = bool mempty (Sum p) $ has _maxPoints gr + , achievedPassPoints = bool mempty (Sum p) $ is _PassPoints gr } diff --git a/src/Utils.hs b/src/Utils.hs index cb2fec606..74e9ca04e 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -153,6 +153,22 @@ iconProblem = fontAwesomeIcon "bolt" iconHint :: Markup iconHint = fontAwesomeIcon "life-ring" +-- Icons for Course +iconCourse :: Markup +iconCourse = fontAwesomeIcon "graduation-cap" + +iconExam :: Markup +iconExam = fontAwesomeIcon "file-invoice" + +iconEnrol :: Bool -> Markup +iconEnrol True = fontAwesomeIcon "user-plus" +iconEnrol False = fontAwesomeIcon "user-slash" + +iconExamRegister :: Bool -> Markup +iconExamRegister True = fontAwesomeIcon "calendar-check" +iconExamRegister False = fontAwesomeIcon "calendar-times" + + -- Icons for SheetFileType iconSolution :: Markup iconSolution =fontAwesomeIcon "exclamation-circle" @@ -170,7 +186,7 @@ iconCSV :: Markup iconCSV = fontAwesomeIcon "file-csv" --- Conditional icons +-- Generic Conditional icons isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible @@ -263,6 +279,9 @@ rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy :: HasR rationalToFixed3 :: Rational -> Fixed E3 rationalToFixed3 = rationalToFixed +rationalToFixed2 :: Rational -> Fixed E2 +rationalToFixed2 = rationalToFixed + -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits textPercent :: Real a => a -> a -> Text @@ -693,6 +712,9 @@ assertM_ f x = guard . f =<< x assertM' :: Alternative m => (a -> Bool) -> a -> m a assertM' f x = x <$ guard (f x) +guardOn :: Alternative m => Bool -> a -> m a +guardOn b x = x <$ guard b + -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 3f66c65ee..97b73481d 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -34,6 +34,9 @@ import Data.Aeson.TH import Utils.PathPiece import Data.Time.Format.Instances () + +import Algebra.Lattice +import Algebra.Lattice.Ordered -- $(timeLocaleMap _) :: [Lang] -> TimeLocale @@ -78,7 +81,7 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } instance Hashable DateTimeFormat -data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime +data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) instance Universe SelDateTimeFormat @@ -98,3 +101,19 @@ instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where def SelFormatDateTime = "%c" def SelFormatDate = "%F" def SelFormatTime = "%T" + +instance JoinSemiLattice SelDateTimeFormat where + a \/ b = getOrdered $ ((\/) `on` Ordered) a b + +instance MeetSemiLattice SelDateTimeFormat where + a /\ b = getOrdered $ ((/\) `on` Ordered) a b + +instance Lattice SelDateTimeFormat + +instance BoundedJoinSemiLattice SelDateTimeFormat where + bottom = SelFormatTime + +instance BoundedMeetSemiLattice SelDateTimeFormat where + top = SelFormatDateTime + +instance BoundedLattice SelDateTimeFormat diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 1749dd51a..73e6473e4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Utils.Form where @@ -198,6 +199,7 @@ data FormIdentifier | FIDDBTable | FIDDBTableCsvExport | FIDDBTableCsvImport + | FIDDBTableCsvImportConfirm | FIDDelete | FIDCourseRegister | FIDuserRights @@ -566,7 +568,26 @@ data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Exception SecretJSONFieldException -secretJsonField :: ( ToJSON a, FromJSON a +secretJsonField' :: ( ToJSON a, FromJSON a + , MonadHandler m + , MonadSecretBox (ExceptT EncodedSecretBoxException m) + , MonadSecretBox (WidgetT (HandlerSite m) IO) + , RenderMessage (HandlerSite m) FormMessage + , RenderMessage (HandlerSite m) SecretJSONFieldException + ) + => FieldViewFunc m Text -> Field m a +secretJsonField' fieldView' = Field{..} + where + fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v) + fieldParse [] [] = return $ Right Nothing + fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired + fieldView theId name attrs val isReq = do + val' <- traverse (encodedSecretBox SecretBoxShort) val + fieldView' theId name attrs val' isReq + fieldEnctype = UrlEncoded + +secretJsonField :: forall m a. + ( ToJSON a, FromJSON a , MonadHandler m , MonadSecretBox (ExceptT EncodedSecretBoxException m) , MonadSecretBox (WidgetT (HandlerSite m) IO) @@ -574,17 +595,7 @@ secretJsonField :: ( ToJSON a, FromJSON a , RenderMessage (HandlerSite m) SecretJSONFieldException ) => Field m a -secretJsonField = Field{..} - where - fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v) - fieldParse [] [] = return $ Right Nothing - fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired - fieldView theId name attrs val _isReq = do - val' <- traverse (encodedSecretBox SecretBoxShort) val - [whamlet| - - |] - fieldEnctype = UrlEncoded +secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text) htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField @@ -601,7 +612,7 @@ fileFieldMultiple = Field [whamlet| $newline never - |] + |] , fieldEnctype = Multipart } @@ -651,13 +662,16 @@ wrapForm' btn formWidget FormSettings{..} = do -- | Use this type to pass information to the form template data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport -renderAForm :: Monad m => FormLayout -> FormRender m a +data AFormMessage = MsgAFormFieldRequiredTip + +renderAForm :: (RenderMessage (HandlerSite m) AFormMessage, Monad m) => FormLayout -> FormRender m a renderAForm formLayout aform fragment = do (res, ($ []) -> fieldViews) <- aFormToForm aform - let widget = $(widgetFile "widgets/aform/aform") + let formHasRequiredFields = any fvRequired fieldViews + widget = $(widgetFile "widgets/aform/aform") return (res, widget) -renderWForm :: MonadHandler m => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here) +renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler m) => FormLayout -> WForm m (FormResult a) -> -- Form a -- (Synonym unavailable here) (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())) renderWForm formLayout = renderAForm formLayout . wFormToAForm @@ -832,9 +846,18 @@ deriving newtype instance Monad m => Applicative (FormValidator r m) deriving newtype instance Monad m => Monad (FormValidator r m) deriving newtype instance Monad m => MonadState r (FormValidator r m) deriving newtype instance MonadFix m => MonadFix (FormValidator r m) +deriving newtype instance MonadResource m => MonadResource (FormValidator r m) +deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m) +deriving newtype instance MonadIO m => MonadIO (FormValidator r m) +instance MonadBase b m => MonadBase b (FormValidator r m) where + liftBase = lift . liftBase instance MonadTrans (FormValidator r) where lift = FormValidator . lift +instance MonadHandler m => MonadHandler (FormValidator r m) where + type HandlerSite (FormValidator r m) = HandlerSite m + liftHandlerT = lift . liftHandlerT + validateForm :: MonadHandler m => FormValidator a m () -> (Markup -> MForm m (FormResult a, xml)) diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 57d1a0cff..6a66df6e1 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -6,7 +6,7 @@ module Utils.Parameters , GlobalPostParam(..) , lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams , lookupGlobalPostParamForm, hasGlobalPostParamForm - , globalPostParamField + , globalPostParamField, globalPostParamFields ) where import ClassyPrelude.Yesod @@ -55,6 +55,7 @@ data GlobalPostParam = PostFormIdentifier | PostDeleteTarget | PostMassInputShape | PostBearer + | PostDBCsvImportAction deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam @@ -84,3 +85,9 @@ globalPostParamField ident Field{fieldParse} = runMaybeT $ do ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles MaybeT $ either (const Nothing) id <$> lift (fieldParse ts fs) + +globalPostParamFields :: Monad m => GlobalPostParam -> Field m a -> MForm m [a] +globalPostParamFields ident Field{fieldParse} = fmap (fromMaybe []) . runMaybeT $ do + ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams + fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles + forM ((Left <$> fs) ++ (Right <$> ts)) $ \inp -> MaybeT $ either (const Nothing) id <$> lift (either (\f -> fieldParse [] [f]) (\t -> fieldParse [t] []) inp) diff --git a/templates/correction-user.hamlet b/templates/correction-user.hamlet index 78a4533b2..252b9d046 100644 --- a/templates/correction-user.hamlet +++ b/templates/correction-user.hamlet @@ -3,10 +3,10 @@ _{MsgSubmission} #{cid} - $maybe Entity _ User{userDisplayName} <- corrector + $maybe Entity _ User{userDisplayName, userSurname, userEmail} <- corrector _{MsgRatingBy} - #{userDisplayName} + ^{nameEmailWidget userEmail userDisplayName userSurname} $maybe time <- submissionRatingTime _{MsgRatingTime} diff --git a/templates/csv-import-confirmation-wrapper.hamlet b/templates/csv-import-confirmation-wrapper.hamlet new file mode 100644 index 000000000..b5459079b --- /dev/null +++ b/templates/csv-import-confirmation-wrapper.hamlet @@ -0,0 +1,4 @@ +

    +

    _{MsgCsvImportConfirmationTip} +

    + ^{csvImportConfirmForm} diff --git a/templates/csv-import-confirmation.hamlet b/templates/csv-import-confirmation.hamlet new file mode 100644 index 000000000..473a2c101 --- /dev/null +++ b/templates/csv-import-confirmation.hamlet @@ -0,0 +1,21 @@ +$newline never +#{csrf} +
    + $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap) +
    + +