From 09196971f8093a0c8b1b6f5ecb94f44090932ae2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 15 May 2019 15:12:00 +0200 Subject: [PATCH 01/17] Rough sketch of models/exams --- models/exams | 60 +++++++++++++++++++++++++++--------------- src/Model/Migration.hs | 4 +++ src/Model/Types.hs | 39 ++++++++++++++++++++++++--- 3 files changed, 79 insertions(+), 24 deletions(-) diff --git a/models/exams b/models/exams index f9d326011..af2ac807f 100644 --- a/models/exams +++ b/models/exams @@ -1,22 +1,40 @@ --- EXAMS ARE TODO; THIS IS JUST AN UNUSED STUB Exam - course CourseId - name Text - description Text - begin UTCTime - end UTCTime - registrationBegin UTCTime - registrationEnd UTCTime - deregistrationEnd UTCTime - ratingVisible Bool -- may participants see their own rating yet - statisticsVisible Bool -- may participants view statistics over all participants (should not be allowed for 'small' courses) ---ExamEdit --- user UserId --- time UTCTime --- exam ExamId ---ExamUser --- user UserId --- examId ExamId --- -- CONTINUE HERE: Include rating in this table or separately? --- UniqueExamUser user examId --- By default this file is used in Model.hs (which is imported by Foundation.hs) \ No newline at end of file + course CourseId + name (CI Text) + gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ... + bonusRule ExamBonusRule + occuranceRule ExamOccuranceRule + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + deregisterUntil UTCTime Maybe + start UTCTime + end UTCTime Maybe + finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out + closed Bool -- Prüfungsamt hat Einsicht (notification) + publicStatistics Bool + description Html Maybe + UniqueExam course name +ExamPart + exam ExamId + name (CI Text) + maxPoints Points Maybe + weight Rational + UniqueExamPart exam name +ExamOccurance + exam ExamId + room Text + capacity Natural +ExamRegistration + exam ExamId + user UserId + occurance ExamOccuranceId Maybe + UniqueExamRegistration exam user +ExamResult + examPart ExamPartId + user UserId + result ExamPartResult + UniqueExamResult examPart user +ExamCorrector + examPart ExamPartId + user UserId + UniqueExamCorrector examPart user \ No newline at end of file diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index f55638835..6a5e36ebb 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -288,6 +288,10 @@ customMigrations = Map.fromListWith (>>) tableDropEmpty "tutorial" tableDropEmpty "tutorial_user" ) + , ( AppliedMigrationKey [migrationVersion|12.0.0|] [version|13.0.0|] + , whenM (tableExists "exam") $ -- Exams were an unused stub before + tableDropEmpty "exam" + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index aa1c91037..d55783fcb 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -366,9 +366,42 @@ classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth -data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "ExamStatus" +data ExamPartResult = ExamAttended { examPartResult :: Maybe Points } + | ExamNoShow + | ExamVoided + deriving (Show, Read, Eq, Ord, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 2 + , omitNothingFields = True + , sumEncoding = TaggedObject "status" "result" + } ''ExamPartResult +derivePersistFieldJSON ''ExamPartResult + +data ExamBonusRule = ExamNoBonus + | ExamBonusPoints + { bonusExchangeRate :: Rational + , bonusOnlyPassed :: Bool + } + deriving (Show, Read, Eq, Ord, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "rule" "settings" + } ''ExamBonusRule +derivePersistFieldJSON ''ExamBonusRule + +data ExamOccuranceRule = ExamRoomManual + | ExamRoomSurname + | ExamRoomMatriculation + | ExamRoomRandom + deriving (Show, Read, Eq, Ord, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "rule" "settings" + } ''ExamOccuranceRule +derivePersistFieldJSON ''ExamOccuranceRule -- | Specify a corrector's workload data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } From dbc0e5d49b19817266fc971afa65ad747e7f4b00 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 May 2019 16:20:15 +0200 Subject: [PATCH 02/17] Visibility timestamp for exams and room assignments --- models/exams | 2 ++ 1 file changed, 2 insertions(+) diff --git a/models/exams b/models/exams index 13dbf658e..7d61e2e6d 100644 --- a/models/exams +++ b/models/exams @@ -4,9 +4,11 @@ Exam gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ... bonusRule ExamBonusRule occurrenceRule ExamOccurenceRule + visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe + publishOccurenceAssignments UTCTime start UTCTime end UTCTime Maybe finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out From 054ff5cdc3c11e934c19a05df76f391bb6a006c8 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 7 Jun 2019 13:42:37 +0200 Subject: [PATCH 03/17] Create new exams --- messages/uniworx/de.msg | 88 +++- models/exams | 25 +- models/tutorials | 2 +- routes | 4 + src/Application.hs | 1 + src/Foundation.hs | 28 ++ src/Handler/Course.hs | 2 +- src/Handler/Exam.hs | 391 ++++++++++++++++++ src/Handler/Tutorial.hs | 8 +- src/Handler/Utils/Exam.hs | 47 +++ src/Handler/Utils/Form.hs | 162 +++++++- .../Form/{Occurences.hs => Occurrences.hs} | 82 ++-- src/Handler/Utils/Table/Cells.hs | 22 +- src/Model/Types/Common.hs | 2 + src/Model/Types/DateTime.hs | 42 +- src/Model/Types/Exam.hs | 81 +++- src/Utils/Form.hs | 60 ++- src/Utils/Lens.hs | 13 +- src/Utils/{Occurences.hs => Occurrences.hs} | 36 +- src/Utils/PathPiece.hs | 14 +- templates/exam-list.hamlet | 2 + templates/exam-new.hamlet | 2 + templates/widgets/gradingKey.hamlet | 15 + .../massinput/examCorrectors/add.hamlet | 6 + .../examCorrectors/cellInvitation.hamlet | 9 + .../massinput/examCorrectors/cellKnown.hamlet | 3 + .../examCorrectors/layout.hamlet} | 0 .../widgets/massinput/examParts/add.hamlet | 4 + .../widgets/massinput/examParts/form.hamlet | 4 + .../widgets/massinput/examParts/layout.hamlet | 16 + .../widgets/massinput/examRooms/add.hamlet | 4 + .../widgets/massinput/examRooms/form.hamlet | 6 + .../widgets/massinput/examRooms/layout.hamlet | 18 + .../uploadSpecificFiles/layout.hamlet | 2 +- .../{occurence => occurrence}/cell.hamlet | 6 +- .../cell/except-no-occurr.hamlet} | 0 .../cell/except-occurr.hamlet} | 0 .../cell/weekly.hamlet | 0 .../form/except-add.hamlet | 0 .../occurrence/form/except-layout.hamlet | 11 + .../form/except-no-occur.hamlet | 0 .../form/except-occur.hamlet | 0 .../occurrence/form/scheduled-add.hamlet | 5 + .../occurrence/form/scheduled-layout.hamlet | 11 + .../form/weekly.hamlet | 0 test/Database.hs | 12 +- 46 files changed, 1093 insertions(+), 153 deletions(-) create mode 100644 src/Handler/Exam.hs create mode 100644 src/Handler/Utils/Exam.hs rename src/Handler/Utils/Form/{Occurences.hs => Occurrences.hs} (59%) rename src/Utils/{Occurences.hs => Occurrences.hs} (65%) create mode 100644 templates/exam-list.hamlet create mode 100644 templates/exam-new.hamlet create mode 100644 templates/widgets/gradingKey.hamlet create mode 100644 templates/widgets/massinput/examCorrectors/add.hamlet create mode 100644 templates/widgets/massinput/examCorrectors/cellInvitation.hamlet create mode 100644 templates/widgets/massinput/examCorrectors/cellKnown.hamlet rename templates/widgets/{occurence/form/scheduled-layout.hamlet => massinput/examCorrectors/layout.hamlet} (100%) create mode 100644 templates/widgets/massinput/examParts/add.hamlet create mode 100644 templates/widgets/massinput/examParts/form.hamlet create mode 100644 templates/widgets/massinput/examParts/layout.hamlet create mode 100644 templates/widgets/massinput/examRooms/add.hamlet create mode 100644 templates/widgets/massinput/examRooms/form.hamlet create mode 100644 templates/widgets/massinput/examRooms/layout.hamlet rename templates/widgets/{occurence => occurrence}/cell.hamlet (64%) rename templates/widgets/{occurence/cell/except-no-occur.hamlet => occurrence/cell/except-no-occurr.hamlet} (100%) rename templates/widgets/{occurence/cell/except-occur.hamlet => occurrence/cell/except-occurr.hamlet} (100%) rename templates/widgets/{occurence => occurrence}/cell/weekly.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-add.hamlet (100%) create mode 100644 templates/widgets/occurrence/form/except-layout.hamlet rename templates/widgets/{occurence => occurrence}/form/except-no-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-occur.hamlet (100%) create mode 100644 templates/widgets/occurrence/form/scheduled-add.hamlet create mode 100644 templates/widgets/occurrence/form/scheduled-layout.hamlet rename templates/widgets/{occurence => occurrence}/form/weekly.hamlet (100%) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 993bffa46..96791ae8b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -631,6 +631,8 @@ MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@S MailSubjectTutorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand tutn@TutorialName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Tutor für #{tutn} +MailSubjectExamCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für Klausur #{examn} + MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zu einer Abgabe für #{shn} SheetGrading: Bewertung @@ -835,6 +837,8 @@ MenuAuthPreds: Authorisierungseinstellungen MenuTutorialDelete: Tutorium löschen MenuTutorialEdit: Tutorium editieren MenuTutorialComm: Mitteilung an Teilnehmer +MenuExamList: Klausuren +MenuExamNew: Neue Klausur anlegen AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -922,6 +926,11 @@ 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} +ExamCorrectorInviteExplanation: Sie wurden eingeladen, Klausur-Korrektor zu sein. + SubmissionUserInvitationAccepted shn@SheetName: Sie wurden als Mitabgebende(r) für eine Abgabe zu #{shn} eingetragen SubmissionUserInvitationDeclined shn@SheetName: Sie haben die Einladung, Mitabgebende(r) für #{shn} zu werden, abgelehnt SubmissionUserInviteHeading shn@SheetName: Einladung zu einer Abgabe für #{shn} @@ -942,8 +951,8 @@ ScheduleRegular: Planmäßiger Termin ScheduleRegularKind: Plan WeekDay: Wochentag Day: Tag -OccurenceStart: Beginn -OccurenceEnd: Ende +OccurrenceStart: Beginn +OccurrenceEnd: Ende ScheduleExists: Dieser Plan existiert bereits ScheduleExceptions: Termin-Ausnahmen @@ -1012,4 +1021,77 @@ CourseParticipantsInvited n@Int: #{tshow n} #{pluralDE n "Einladung" "Einladunge CourseParticipantsAlreadyRegistered n@Int: #{tshow n} Teilnehmer #{pluralDE n "ist" "sind"} bereits angemeldet CourseParticipantsRegisteredWithoutField n@Int: #{tshow 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"} CourseParticipantsRegistered n@Int: #{tshow n} Teilnehmer erfolgreich angemeldet -CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen \ No newline at end of file +CourseParticipantsRegisterHeading: Kursteilnehmer hinzufügen + +ExamName: Name +ExamTime: Termin +ExamsHeading: Klausuren +ExamNameTip: Muss innerhalb der Veranstaltung eindeutig sein +ExamStart: Beginn +ExamEnd: Ende +ExamDescription: Beschreibung +ExamVisibleFrom: Sichtbar ab +ExamVisibleFromTip: Ohne Datum nie sichtbar und keine Anmeldung möglich +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 +ExamFinished: Bewertung abgeschlossen ab +ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden +ExamClosed: Noten stehen fest ab +ExamClosedTip: Zeitpunkt ab dem keine Änderungen an den Ergebnissen zulässig sind; Prüfungsämter bekommen Einsicht +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 +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 +Points: Punkte +PointsMustBeNonNegative: Punktegrenzen dürfen nicht negativ sein +PointsMustBeMonotonic: Punktegrenzen müssen aufsteigend sein +GradingFrom: Ab +ExamNew: Neue Klausur +ExamBonusRule: Klausurbonus aus Übungsbetrieb +ExamNoBonus': Kein Bonus +ExamBonusPoints': Umrechnung von Übungspunkten + +ExamBonusMaxPoints: Maximal erreichbare Klausur-Bonuspunkte +ExamBonusMaxPointsNonPositive: Maximaler Klausurbonus muss positiv und größer null sein +ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen + +ExamOccurrenceRule: Automatische Terminzuteilung +ExamRoomManual': Keine automatische Zuteilung +ExamRoomSurname': Nach Nachname +ExamRoomMatriculation': Nach Matrikelnummer +ExamRoomRandom': Zufällig pro Teilnehmer + +ExamOccurrences: Prüfungen +ExamRoomAlreadyExists: Prüfung ist bereits eingetragen +ExamRoom: Raum +ExamRoomCapacity: Kapazität +ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein +ExamRoomStart: Beginn +ExamRoomEnd: Ende +ExamRoomDescription: Beschreibung +ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung + +ExamFormTimes: Zeiten +ExamFormOccurrences: Prüfungstermine +ExamFormAutomaticFunctions: Automatische Funktionen +ExamFormCorrection: Korrektur +ExamFormParts: Teile + +ExamCorrectors: Korrektoren +ExamCorrectorAlreadyAdded: Ein Korrektor mit dieser E-Mail ist bereits für diese Klausur eingetragen + +ExamParts: Teilaufgaben +ExamPartWeightNegative: Gewicht aller Teilaufgaben muss größer oder gleich Null sein +ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits +ExamPartName: Name +ExamPartMaxPoints: Maximalpunktzahl +ExamPartWeight: Gewichtung + +ExamNameTaken exam@ExamName: Es existiert bereits eine Klausur mit Namen #{exam} +ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt \ No newline at end of file diff --git a/models/exams b/models/exams index 7d61e2e6d..b6ed523e2 100644 --- a/models/exams +++ b/models/exams @@ -1,18 +1,18 @@ Exam course CourseId - name (CI Text) - gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ... + name ExamName + gradingRule ExamGradingRule bonusRule ExamBonusRule - occurrenceRule ExamOccurenceRule + occurrenceRule ExamOccurrenceRule visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe deregisterUntil UTCTime Maybe - publishOccurenceAssignments UTCTime + publishOccurrenceAssignments UTCTime start UTCTime end UTCTime Maybe finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out - closed Bool -- Prüfungsamt hat Einsicht (notification) + closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification) publicStatistics Bool description Html Maybe UniqueExam course name @@ -22,14 +22,17 @@ ExamPart maxPoints Points Maybe weight Rational UniqueExamPart exam name -ExamOccurence +ExamOccurrence exam ExamId room Text capacity Natural + start UTCTime + end UTCTime Maybe + description Html Maybe ExamRegistration exam ExamId user UserId - occurance ExamOccurenceId Maybe + occurance ExamOccurrenceId Maybe UniqueExamRegistration exam user ExamResult examPart ExamPartId @@ -37,6 +40,10 @@ ExamResult result ExamPartResult UniqueExamResult examPart user ExamCorrector - examPart ExamPartId + exam ExamId user UserId - UniqueExamCorrector examPart user \ No newline at end of file + UniqueExamCorrector exam user +ExamPartCorrector + part ExamPartId + corrector ExamCorrector + UniqueExamPartCorrector part corrector \ No newline at end of file diff --git a/models/tutorials b/models/tutorials index 4961e0bd5..166a8dbef 100644 --- a/models/tutorials +++ b/models/tutorials @@ -4,7 +4,7 @@ Tutorial json type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room Text - time Occurences + time Occurrences regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/routes b/routes index 31885f668..abed932c2 100644 --- a/routes +++ b/routes @@ -136,6 +136,10 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST + /exams CExamListR GET !development -- Missing permission checks on which exams can be shown + /exams/new CExamNewR GET POST + /exams/#ExamName ExamR: + /corrector-invite ECInviteR GET POST /subs CorrectionsR GET POST !corrector !lecturer diff --git a/src/Application.hs b/src/Application.hs index ab612883c..3e20e6613 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -113,6 +113,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Exam -- This line actually creates our YesodDispatch instance. It is the second half diff --git a/src/Foundation.hs b/src/Foundation.hs index 4567440f8..dc3621858 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -181,6 +181,10 @@ pattern CTutorialR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> T pattern CTutorialR tid ssh csh tnm ptn = CourseR tid ssh csh (TutorialR tnm ptn) +pattern CExamR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> ExamR -> Route UniWorX +pattern CExamR tid ssh csh tnm ptn + = CourseR tid ssh csh (ExamR tnm ptn) + pattern CSubmissionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionR -> Route UniWorX pattern CSubmissionR tid ssh csh shn cid ptn = CSheetR tid ssh csh shn (SubmissionR cid ptn) @@ -318,6 +322,9 @@ instance RenderMessage UniWorX StudyDegreeTerm where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls +instance RenderMessage UniWorX ExamGrade where + renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade + newtype ErrorResponseTitle = ErrorResponseTitle ErrorResponse @@ -1436,6 +1443,9 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR) + breadcrumb (CourseR tid ssh csh CExamListR) = return ("Klausuren", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) @@ -1876,6 +1886,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseMembers @@ -2080,6 +2098,16 @@ pageActions (CTutorialR tid ssh csh tutn TUsersR) = , menuItemAccessCallback' = return True } ] +pageActions (CourseR tid ssh csh CExamListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5abd1e624..c31b7048c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -360,7 +360,7 @@ getCShowR tid ssh csh = do ^{nameEmailWidget' tutor} |] , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs new file mode 100644 index 000000000..4f1c4917a --- /dev/null +++ b/src/Handler/Exam.hs @@ -0,0 +1,391 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Exam where + +import Import + +import Handler.Utils +import Handler.Utils.Exam +import Handler.Utils.Invitations +import Jobs.Queue + +import Utils.Lens + +import qualified Database.Esqueleto as E + +import Data.Map ((!)) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) +import Text.Blaze.Html.Renderer.String (renderHtml) + + +getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamListR tid ssh csh = do + Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + + let + examDBTable = DBTable{..} + where + dbtSQLQuery exam = do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return exam + dbtRowKey = (E.^. ExamId) + dbtProj = return + dbtColonnade = dbColonnade $ mconcat + [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ toWidget examName + , 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'} + |] + ] + dbtSorting = Map.fromList + [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) + , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "exams" + + examDBTableValidator = def + & defaultSorting [SortAscBy "time"] + ((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable + + siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do + setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading + $(widgetFile "exam-list") + + +instance IsInvitableJunction ExamCorrector where + type InvitationFor ExamCorrector = Exam + data InvitableJunction ExamCorrector = JunctionExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationDBData ExamCorrector = InvDBDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + _InvitableJunction = iso + (\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector)) + (\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..}) + +instance ToJSON (InvitableJunction ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } +instance FromJSON (InvitableJunction ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } + +instance ToJSON (InvitationDBData ExamCorrector) where + toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationDBData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } + +instance ToJSON (InvitationTokenData ExamCorrector) where + toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } +instance FromJSON (InvitationTokenData ExamCorrector) where + parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } + +examCorrectorInvitationConfig :: InvitationConfig ExamCorrector +examCorrectorInvitationConfig = InvitationConfig{..} + where + invitationRoute (Entity _ Exam{..}) _ = do + Course{..} <- get404 examCourse + return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR + invitationResolveFor = do + Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute + fetchExamId tid csh ssh examn + invitationSubject Exam{..} _ = do + Course{..} <- get404 examCourse + return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName + invitationHeading Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName + invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|] + invitationTokenConfig _ _ = do + itAuthority <- liftHandlerT requireAuthId + return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing + invitationRestriction _ _ = return Authorized + invitationForm _ _ _ = pure JunctionExamCorrector + invitationSuccessMsg Exam{..} _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName + invitationUltDest Exam{..} _ = do + Course{..} <- get404 examCourse + return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CExamListR + +getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getECInviteR = postECInviteR +postECInviteR = invitationR examCorrectorInvitationConfig + + +data ExamForm = ExamForm + { efName :: ExamName + , efDescription :: Maybe Html + , efStart :: UTCTime + , efEnd :: Maybe UTCTime + , efVisibleFrom :: Maybe UTCTime + , efRegisterFrom :: Maybe UTCTime + , efRegisterTo :: Maybe UTCTime + , efDeregisterUntil :: Maybe UTCTime + , efPublishOccurrenceAssignments :: UTCTime + , efFinished :: Maybe UTCTime + , efClosed :: Maybe UTCTime + , efOccurrences :: Set ExamOccurrenceForm + , efPublicStatistics :: Bool + , efGradingRule :: ExamGradingRule + , efBonusRule :: ExamBonusRule + , efOccurrenceRule :: ExamOccurrenceRule + , efCorrectors :: Set (Either UserEmail UserId) + , efExamParts :: Set ExamPartForm + } + +data ExamOccurrenceForm = ExamOccurrenceForm + { eofRoom :: Text + , eofCapacity :: Natural + , eofStart :: UTCTime + , eofEnd :: Maybe UTCTime + , eofDescription :: Maybe Html + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +data ExamPartForm = ExamPartForm + { epfName :: ExamPartName + , epfMaxPoints :: Maybe Points + , epfWeight :: Rational + } deriving (Read, Show, Eq, Ord, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamPartForm + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamOccurrenceForm + + +examForm :: Maybe ExamForm -> Form ExamForm +examForm template html = do + MsgRenderer mr <- getMsgRenderer + + flip (renderAForm FormStandard) html $ ExamForm + <$> 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 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)) (efPublishOccurrenceAssignments <$> template) + <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) + <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) + <* aformSection MsgExamFormOccurrences + <*> examOccurrenceForm (efOccurrences <$> template) + <* aformSection MsgExamFormAutomaticFunctions + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template)) + <*> examGradingRuleForm (efGradingRule <$> template) + <*> bonusRuleForm (efBonusRule <$> template) + <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) + <* aformSection MsgExamFormCorrection + <*> examCorrectorsForm (efCorrectors <$> template) + <* aformSection MsgExamFormParts + <*> examPartsForm (efExamParts <$> template) + +examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) +examCorrectorsForm mPrev = wFormToAForm $ do + MsgRenderer mr <- getMsgRenderer + Just currentRoute <- getCurrentRoute + uid <- liftHandlerT requireAuthId + + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId]) + miAdd' nudge submitView csrf = do + (addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing + let + addRes' + | otherwise + = addRes <&> \newDat oldDat -> if + | existing <- newDat `Set.intersection` Set.fromList oldDat + , not $ Set.null existing + -> FormFailure [mr MsgExamCorrectorAlreadyAdded] + | otherwise + -> FormSuccess $ Set.toList newDat + return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add")) + + corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User)) + corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do + E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser + E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId + E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId + E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + return corrUser + + + miCell' :: Either UserEmail UserId -> Widget + miCell' (Left email) = + $(widgetFile "widgets/massinput/examCorrectors/cellInvitation") + miCell' (Right userId) = do + User{..} <- liftHandlerT . runDB $ get404 userId + $(widgetFile "widgets/massinput/examCorrectors/cellKnown") + + 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) + +examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm) +examOccurrenceForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + 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 + where + examOccurrenceForm' nudge mPrev csrf = do + (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) + (eofCapacityRes, eofCapacityView) <- mpreq (posIntFieldI MsgExamRoomCapacityNonPositive) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) + (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) + (eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev) + (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) + + return ( ExamOccurrenceForm + <$> eofRoomRes + <*> eofCapacityRes + <*> eofStartRes + <*> eofEndRes + <*> (assertM (not . null . renderHtml) <$> eofDescRes) + , $(widgetFile "widgets/massinput/examRooms/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examOccurrenceForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examRooms/add")) + miCell' nudge dat = examOccurrenceForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout") + miIdent' :: Text + miIdent' = "exam-occurrences" + +examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm) +examPartsForm prev = wFormToAForm $ do + Just currentRoute <- getCurrentRoute + 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 + where + examPartForm' nudge mPrev csrf = do + (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) + (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) + (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) + + return ( ExamPartForm + <$> epfNameRes + <*> epfMaxPointsRes + <*> epfWeightRes + , $(widgetFile "widgets/massinput/examParts/form") + ) + + miAdd' nudge submitView csrf = do + MsgRenderer mr <- getMsgRenderer + (res, formWidget) <- examPartForm' nudge Nothing csrf + let + addRes = res <&> \newDat (Set.fromList -> oldDat) -> if + | any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists] + | otherwise -> FormSuccess $ pure newDat + return (addRes, $(widgetFile "widgets/massinput/examParts/add")) + miCell' nudge dat = examPartForm' nudge (Just dat) + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout") + miIdent' :: Text + miIdent' = "exam-parts" + +getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCExamNewR = postCExamNewR +postCExamNewR tid ssh csh = do + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm Nothing + + formResult newExamResult $ \ExamForm{..} -> do + insertRes <- runDBJobs $ do + insertRes <- insertUnique Exam + { examName = efName + , examCourse = cid + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = efClosed + , examPublicStatistics = efPublicStatistics + , examDescription = efDescription + } + whenIsJust insertRes $ \examid -> do + insertMany_ + [ ExamPart{..} + | ExamPartForm{..} <- Set.toList efExamParts + , let examPartExam = examid + examPartName = epfName + examPartMaxPoints = epfMaxPoints + examPartWeight = epfWeight + ] + + insertMany_ + [ ExamOccurrence{..} + | ExamOccurrenceForm{..} <- Set.toList efOccurrences + , let examOccurrenceExam = examid + examOccurrenceRoom = eofRoom + examOccurrenceCapacity = eofCapacity + examOccurrenceStart = eofStart + examOccurrenceEnd = eofEnd + examOccurrenceDescription = eofDescription + ] + + let (invites, adds) = partitionEithers $ Set.toList efCorrectors + insertMany_ [ ExamCorrector{..} + | examCorrectorUser <- adds + , let examCorrectorExam = examid + ] + sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + return insertRes + case insertRes of + Nothing -> addMessageI Error $ MsgExamNameTaken efName + Just _ -> do + addMessageI Success $ MsgExamCreated efName + redirect $ CourseR tid ssh csh CExamListR + + let heading = prependCourseTitle tid ssh csh MsgExamNew + + siteLayoutMsg heading $ do + setTitleI heading + let + newExamForm = wrapForm newExamWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR + , formEncoding = newExamEnctype + } + $(widgetFile "exam-new") diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 2a98110c1..964dfa1b3 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Table.Cells import Handler.Utils.Delete import Handler.Utils.Communication -import Handler.Utils.Form.Occurences +import Handler.Utils.Form.Occurrences import Handler.Utils.Invitations import Jobs.Queue @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo @@ -275,7 +275,7 @@ data TutorialForm = TutorialForm , tfType :: CI Text , tfCapacity :: Maybe Int , tfRoom :: Text - , tfTime :: Occurences + , tfTime :: Occurrences , tfRegGroup :: Maybe (CI Text) , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime @@ -322,7 +322,7 @@ tutorialForm cid template html = do <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurencesAForm ("occurences" :: Text) (tfTime <$> template) + <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs new file mode 100644 index 000000000..249d98b73 --- /dev/null +++ b/src/Handler/Utils/Exam.hs @@ -0,0 +1,47 @@ +module Handler.Utils.Exam + ( fetchExamAux + , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam + ) where + +import Import + +import Database.Persist.Sql (SqlBackendCanRead) +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Internal.Sql as E +import Database.Esqueleto.Utils.TH + +import Utils.Lens + + +fetchExamAux :: ( SqlBackendCanRead backend + , E.SqlSelect b a + , MonadHandler m + , Typeable a + ) + => (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b) + -> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a +fetchExamAux prj tid ssh csh examn = + let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn) + in cachedBy cachId $ do + tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do + E.on $ course E.^. CourseId E.==. tut E.^. ExamCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. tut E.^. ExamName E.==. E.val examn + return $ prj tut course + case tutList of + [tut] -> return tut + _other -> notFound + +fetchExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> DB (Entity Exam) +fetchExam = fetchExamAux const + +fetchExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Exam) +fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn + +fetchCourseIdExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Key Exam) +fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn + +fetchCourseIdExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Entity Exam) +fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 0b6850b24..ea6d929b3 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -19,7 +19,6 @@ import qualified Data.CaseInsensitive as CI -- import Yesod.Core import qualified Data.Text as T -- import Yesod.Form.Types -import Yesod.Form.Functions (parseHelper) import Yesod.Form.Bootstrap3 import Handler.Utils.Zip @@ -38,8 +37,6 @@ import Control.Monad.Trans.Except (throwE, runExceptT) import Control.Monad.Writer.Class import Control.Monad.Error.Class (MonadError(..)) -import Data.Scientific (Scientific) -import Text.Read (readMaybe) import Data.Either (partitionEithers) import Utils.Lens @@ -56,6 +53,9 @@ import Yesod.Core.Types (FileInfo(..)) import System.FilePath (isExtensionOf) import Data.Text.Lens (unpacked) +import Data.Char (isDigit) +import Text.Blaze (toMarkup) + import Handler.Utils.Form.MassInput ---------------------------- @@ -241,35 +241,28 @@ htmlField' = htmlField } natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i -natFieldI msg = checkBool (>= 0) msg intField +natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg intField natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField +natField d = convertField fromInteger toInteger $ checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") intField natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer natIntField = natField posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i -posIntField d = checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField +posIntField d = convertField fromInteger toInteger $ checkBool (> 0) (T.append d " muss eine positive Zahl sein.") intField + +posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i +posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg intField -- | Field to request integral number > 'm' minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField -pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions -pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} - where - fieldEnctype = UrlEncoded - fieldView theId name attrs val isReq - = [whamlet| - $newline never - - |] - fieldParse = parseHelper $ \t -> do - sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) - return . fromRational $ round (sci * 100) % 100 +pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points +pointsField = checkBool (>= 0) MsgPointsNotPositive fixedPrecField -pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions +pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points pointsFieldMax Nothing = pointsField pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField @@ -448,6 +441,137 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c ) ] +data ExamBonusRule' = ExamNoBonus' + | ExamBonusPoints' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamBonusRule' +instance Finite ExamBonusRule' + +nullaryPathPiece ''ExamBonusRule' $ camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamBonusRule' id + +classifyBonusRule :: ExamBonusRule -> ExamBonusRule' +classifyBonusRule = \case + ExamNoBonus -> ExamNoBonus' + ExamBonusPoints{} -> ExamBonusPoints' + +bonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule +bonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classifyBonusRule <$> prev + where + actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule) + actions = Map.fromList + [ ( ExamNoBonus' + , pure ExamNoBonus + ) + , ( ExamBonusPoints' + , ExamBonusPoints + <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) + <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + ) + ] + +data ExamOccurrenceRule' = ExamRoomManual' + | ExamRoomSurname' + | ExamRoomMatriculation' + | ExamRoomRandom' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamOccurrenceRule' +instance Finite ExamOccurrenceRule' + +nullaryPathPiece ''ExamOccurrenceRule' $ camelToPathPiece' 1 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id + +classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule' +classifyExamOccurrenceRule = \case + ExamRoomManual -> ExamRoomManual' + ExamRoomSurname -> ExamRoomSurname' + ExamRoomMatriculation -> ExamRoomMatriculation' + ExamRoomRandom -> ExamRoomRandom' + +examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule +examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamOccurrenceRule) . fmap classifyExamOccurrenceRule + where + reverseClassify = \case + ExamRoomManual' -> ExamRoomManual + ExamRoomSurname' -> ExamRoomSurname + ExamRoomMatriculation' -> ExamRoomMatriculation + ExamRoomRandom' -> ExamRoomRandom + +data ExamGradingRule' = ExamGradingManual' + | ExamGradingKey' + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamGradingRule' +instance Finite ExamGradingRule' + +nullaryPathPiece ''ExamGradingRule' $ camelToPathPiece' 2 . dropSuffix "'" +embedRenderMessage ''UniWorX ''ExamGradingRule' id + +classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule' +classifyExamGradingRule = \case + ExamGradingManual -> ExamGradingManual' + ExamGradingKey{} -> ExamGradingKey' + +examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule +examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ classifyExamGradingRule <$> prev + where + actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule) + actions = Map.fromList + [ ( ExamGradingManual' + , pure ExamGradingManual + ) + , ( ExamGradingKey' + , ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev) + ) + ] + + + gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points] + gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do + MsgRenderer mr <- getMsgRenderer + + fvId <- maybe newIdent return fsId + fvName <- maybe newFormIdent return fsName + + let + grades :: [ExamGrade] + grades = universeF + + let boundsFS (Text.filter isDigit . toPathPiece -> g) = "" + & addPlaceholder (mr MsgPoints) + & addName (fvName <> "__" <> g) + & addId (fvId <> "__" <> g) + bounds <- forM grades $ \case + g@Grade50 -> mforced pointsField (boundsFS g) 0 + grade -> mpreq pointsField (boundsFS grade) $ preview (ix . pred $ fromEnum grade) =<< template + + let errors + | anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative] + | FormSuccess bounds' <- sequence $ map (view _1) bounds + , not $ monotone bounds' + = [mr MsgPointsMustBeMonotonic] + | otherwise + = [] + + return ( if + | null errors -> sequence . unsafeTail $ map fst bounds + | otherwise -> FormFailure errors + , FieldView + { fvLabel = toMarkup $ mr fsLabel + , fvTooltip = toMarkup . mr <$> fsTooltip + , fvId + , fvInput = $(widgetFile "widgets/gradingKey") + , fvErrors = if + | (e : _) <- errors -> Just $ toMarkup e + | otherwise -> Nothing + , fvRequired = True + } + ) + + where + monotone (x1:x2:xs) = x1 <= x2 && monotone (x2:xs) + monotone _ = True + + pseudonymWordField :: Field Handler PseudonymWord pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist) where diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurrences.hs similarity index 59% rename from src/Handler/Utils/Form/Occurences.hs rename to src/Handler/Utils/Form/Occurrences.hs index da0e7733f..9fb8118e4 100644 --- a/src/Handler/Utils/Form/Occurences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -1,5 +1,5 @@ -module Handler.Utils.Form.Occurences - ( occurencesAForm +module Handler.Utils.Form.Occurrences + ( occurrencesAForm ) where import Import @@ -13,32 +13,32 @@ import qualified Data.Map as Map import Utils.Lens -data OccurenceScheduleKind = ScheduleKindWeekly +data OccurrenceScheduleKind = ScheduleKindWeekly deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceScheduleKind -instance Finite OccurenceScheduleKind +instance Universe OccurrenceScheduleKind +instance Finite OccurrenceScheduleKind -nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceScheduleKind id +nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id -data OccurenceExceptionKind = ExceptionKindOccur - | ExceptionKindNoOccur +data OccurrenceExceptionKind = ExceptionKindOccur + | ExceptionKindNoOccur deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceExceptionKind -instance Finite OccurenceExceptionKind +instance Universe OccurrenceExceptionKind +instance Finite OccurrenceExceptionKind -nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceExceptionKind id +nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id -occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences -occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do +occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences +occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute let - scheduled :: AForm Handler (Set OccurenceSchedule) + scheduled :: AForm Handler (Set OccurrenceSchedule) scheduled = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -47,16 +47,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__scheduled" :: Text) (fslI MsgScheduleRegular & setTooltip MsgMassInputTip) False - (Set.toList . occurencesScheduled <$> mPrev) + (Set.toList . occurrencesScheduled <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do newSched <- multiActionW (Map.fromList [ ( ScheduleKindWeekly , ScheduleWeekly <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -65,16 +65,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists] | otherwise -> FormSuccess $ pure newSched' - miCell' :: OccurenceSchedule -> Widget + miCell' :: OccurrenceSchedule -> Widget miCell' ScheduleWeekly{..} = do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/form/weekly") + $(widgetFile "widgets/occurrence/form/weekly") - miLayout' :: MassInputLayout ListLength OccurenceSchedule () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout") + miLayout' :: MassInputLayout ListLength OccurrenceSchedule () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/scheduled-layout") - exceptions :: AForm Handler (Set OccurenceException) + exceptions :: AForm Handler (Set OccurrenceException) exceptions = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -83,19 +83,19 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__exceptions" :: Text) (fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip])) False - (Set.toList . occurencesExceptions <$> mPrev) + (Set.toList . occurrencesExceptions <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do newExc <- multiActionW (Map.fromList [ ( ExceptionKindOccur - , ExceptOccur + , ExceptOccurr <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) , ( ExceptionKindNoOccur - , ExceptNoOccur + , ExceptNoOccurr <$> apreq localTimeField (fslI MsgExceptionNoOccurAt & addName (nudge "no-occur-time")) Nothing ) ] @@ -106,18 +106,18 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | otherwise -> FormSuccess $ pure newExc' - miCell' :: OccurenceException -> Widget - miCell' ExceptOccur{..} = do + miCell' :: OccurrenceException -> Widget + miCell' ExceptOccurr{..} = do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd - $(widgetFile "widgets/occurence/form/except-occur") - miCell' ExceptNoOccur{..} = do + $(widgetFile "widgets/occurrence/form/except-occur") + miCell' ExceptNoOccurr{..} = do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/form/except-no-occur") + $(widgetFile "widgets/occurrence/form/except-no-occur") - miLayout' :: MassInputLayout ListLength OccurenceException () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout") + miLayout' :: MassInputLayout ListLength OccurrenceException () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout") - aFormToWForm $ Occurences + aFormToWForm $ Occurrences <$> scheduled <*> exceptions diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 620e6776b..a16d088c2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Text.Blaze (ToMarkup(..)) import Utils.Lens import Handler.Utils -import Utils.Occurences +import Utils.Occurrences import qualified Data.Set as Set @@ -248,19 +248,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurencesCell :: IsDBTable m a => Occurences -> DBCell m a -occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do - let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case +occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do + let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/cell/weekly") - occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case - ExceptOccur{..} -> do + $(widgetFile "widgets/occurrence/cell/weekly") + occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case + ExceptOccurr{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart - $(widgetFile "widgets/occurence/cell/except-occur") - ExceptNoOccur{..} -> do + $(widgetFile "widgets/occurrence/cell/except-occurr") + ExceptNoOccurr{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/cell/except-no-occur") - $(widgetFile "widgets/occurence/cell") + $(widgetFile "widgets/occurrence/cell/except-no-occurr") + $(widgetFile "widgets/occurrence/cell") diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 5ffbcfb07..94966e1c1 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -27,6 +27,8 @@ type SheetName = CI Text type MaterialName = CI Text type UserEmail = CI Email type TutorialName = CI Text +type ExamName = CI Text +type ExamPartName = CI Text type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString type InstanceId = UUID diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 10783550e..aa0226c34 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -2,7 +2,7 @@ Module: Model.Types.DateTime Description: Time related types -Terms, Seasons, and Occurence schedules +Terms, Seasons, and Occurrence schedules -} module Model.Types.DateTime ( module Model.Types.DateTime @@ -152,11 +152,11 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 termYear = year term -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } +data OccurrenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions @@ -164,31 +164,31 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule + } ''OccurrenceSchedule -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } +data OccurrenceException = ExceptOccurr + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccurr + { exceptTime :: LocalTime + } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException + } ''OccurrenceException -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException +data Occurrences = Occurrences + { occurrencesScheduled :: Set OccurrenceSchedule + , occurrencesExceptions :: Set OccurrenceException } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences + } ''Occurrences +derivePersistFieldJSON ''Occurrences diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 66abbe195..1f8d5876f 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -9,6 +9,8 @@ module Model.Types.Exam import Import.NoModel import Model.Types.Common +import Control.Lens + data ExamPartResult = ExamAttended { examPartResult :: Maybe Points } | ExamNoShow | ExamVoided @@ -23,7 +25,7 @@ derivePersistFieldJSON ''ExamPartResult data ExamBonusRule = ExamNoBonus | ExamBonusPoints - { bonusExchangeRate :: Rational + { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool } deriving (Show, Read, Eq, Ord, Generic, Typeable) @@ -34,14 +36,79 @@ deriveJSON defaultOptions } ''ExamBonusRule derivePersistFieldJSON ''ExamBonusRule -data ExamOccurenceRule = ExamRoomManual - | ExamRoomSurname - | ExamRoomMatriculation - | ExamRoomRandom +data ExamOccurrenceRule = ExamRoomManual + | ExamRoomSurname + | ExamRoomMatriculation + | ExamRoomRandom deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 , fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "rule" "settings" - } ''ExamOccurenceRule -derivePersistFieldJSON ''ExamOccurenceRule + } ''ExamOccurrenceRule +derivePersistFieldJSON ''ExamOccurrenceRule + +data ExamGrade + = Grade50 + | Grade40 + | Grade37 + | Grade33 + | Grade30 + | Grade27 + | Grade23 + | Grade20 + | Grade17 + | Grade13 + | Grade10 + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamGrade +instance Finite ExamGrade + +numberGrade :: Prism' Rational ExamGrade +numberGrade = prism toNumberGrade fromNumberGrade + where + toNumberGrade = \case + Grade50 -> 5.0 + Grade40 -> 4.0 + Grade37 -> 3.7 + Grade33 -> 3.3 + Grade30 -> 3.0 + Grade27 -> 2.7 + Grade23 -> 2.3 + Grade20 -> 2.0 + Grade17 -> 1.7 + Grade13 -> 1.3 + Grade10 -> 1.0 + fromNumberGrade = \case + 5.0 -> Right Grade50 + 4.0 -> Right Grade40 + 3.7 -> Right Grade37 + 3.3 -> Right Grade33 + 3.0 -> Right Grade30 + 2.7 -> Right Grade27 + 2.3 -> Right Grade23 + 2.0 -> Right Grade20 + 1.7 -> Right Grade17 + 1.3 -> Right Grade13 + 1.0 -> Right Grade10 + n -> Left n + +instance PathPiece ExamGrade where + toPathPiece = tshow . review numberGrade + fromPathPiece = finiteFromPathPiece + +pathPieceJSON ''ExamGrade +pathPieceJSONKey ''ExamGrade + +data ExamGradingRule + = ExamGradingManual + | ExamGradingKey + { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4.7@, @n2 <= p < n3 -> p ~ 4.3@, ..., @n11 <= p -> p ~ 1.0@ + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 2 + , sumEncoding = TaggedObject "rule" "settings" + } ''ExamGradingRule +derivePersistFieldJSON ''ExamGradingRule diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 2e5f22004..7690db79c 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -34,6 +34,10 @@ import Web.PathPieces import Data.UUID +import Data.Ratio ((%)) +import Data.Fixed +import Data.Scientific + import Utils -- import Utils.Message -- import Utils.PathPiece @@ -41,6 +45,10 @@ import Utils import Data.Proxy +import Text.HTML.SanitizeXSS (sanitizeBalance) +import Text.Blaze (preEscapedText) +import Text.Blaze.Html.Renderer.Pretty (renderHtml) + @@ -444,8 +452,52 @@ optionsFinite = do } return . mkOptionList $ mkOption <$> universeF +fractionalField :: forall m a. + ( RealFrac a + , Monad m + , RenderMessage (HandlerSite m) FormMessage + ) => Field m a +-- | Form `Field` for any `Fractional` number +-- +-- Use more specific `Field`s (i.e. `fixedPrecField`) whenever they exist +fractionalField = Field{..} + where + scientific' :: Iso' a Scientific + scientific' = iso (fromRational . toRational) (fromRational . toRational) + + fieldEnctype = UrlEncoded + fieldView theId name attrs (fmap $ view scientific' -> val) isReq + = [whamlet| + $newline never + + |] + fieldParse = parseHelper $ \t -> + maybe (Left $ MsgInvalidNumber t) (Right . review scientific') (readMay t :: Maybe Scientific) + +fixedPrecField :: forall m p. + ( Monad m + , RenderMessage (HandlerSite m) FormMessage + , HasResolution p + ) => Field m (Fixed p) +fixedPrecField = Field{..} + where + resolution' :: Integer + resolution' = resolution $ Proxy @p + + step = showFixed True (fromRational $ 1 % resolution' :: Fixed p) + + fieldEnctype = UrlEncoded + fieldView theId name attrs val isReq + = [whamlet| + $newline never + + |] + fieldParse = parseHelper $ \t -> do + sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific) + return . fromRational $ round (sci * fromIntegral resolution') % resolution' + rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational -rationalField = convertField toRational fromRational doubleField +rationalField = fractionalField data SecretJSONFieldException = SecretJSONFieldDecryptFailure deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) @@ -471,6 +523,12 @@ secretJsonField = Field{..} |] fieldEnctype = UrlEncoded +htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html +htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField + where + sanitize :: Text -> m (Either FormMessage Html) + sanitize = return . Right . preEscapedText . sanitizeBalance + ----------- -- Forms -- ----------- diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b4cd5a572..955b7dcf6 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -111,18 +111,21 @@ makeLenses_ ''SubmissionMode makePrisms ''E.Value -makeLenses_ ''OccurenceSchedule +makeLenses_ ''OccurrenceSchedule -makePrisms ''OccurenceSchedule +makePrisms ''OccurrenceSchedule -makeLenses_ ''OccurenceException +makeLenses_ ''OccurrenceException -makePrisms ''OccurenceException +makePrisms ''OccurrenceException -makeLenses_ ''Occurences +makeLenses_ ''Occurrences makeLenses_ ''PredDNF +makeLenses_ ''ExamBonusRule +makeLenses_ ''ExamGradingRule + -- makeClassy_ ''Load diff --git a/src/Utils/Occurences.hs b/src/Utils/Occurrences.hs similarity index 65% rename from src/Utils/Occurences.hs rename to src/Utils/Occurrences.hs index 077d79250..6de64fac3 100644 --- a/src/Utils/Occurences.hs +++ b/src/Utils/Occurrences.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -module Utils.Occurences - ( normalizeOccurences +module Utils.Occurrences + ( normalizeOccurrences ) where import ClassyPrelude @@ -20,21 +20,21 @@ import Data.Time import Data.Time.Calendar.WeekDate -normalizeOccurences :: Occurences -> Occurences +normalizeOccurrences :: Occurrences -> Occurrences -- ^ -- -- - Removes unnecessary exceptions -- - Merges overlapping schedules -normalizeOccurences initial +normalizeOccurrences initial | Left new <- runReader (runExceptT go) initial - = normalizeOccurences new + = normalizeOccurrences new | otherwise = initial where - go :: ExceptT Occurences (Reader Occurences) () + go :: ExceptT Occurrences (Reader Occurrences) () -- Find some inconsistency and `throwE` a version without it go = do - scheduled <- view _occurencesScheduled + scheduled <- view _occurrencesScheduled forM_ scheduled $ \case a@ScheduleWeekly{} -> do let @@ -50,35 +50,35 @@ normalizeOccurences initial | otherwise = Nothing merge _ = Nothing - merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a + merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a case merges of [] -> return () - ((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) + ((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) - exceptions <- view _occurencesExceptions + exceptions <- view _occurrencesExceptions forM_ exceptions $ \case - needle@ExceptNoOccur{..} -> do + needle@ExceptNoOccurr{..} -> do let LocalTime{..} = exceptTime (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay - needed <- views _occurencesScheduled . any $ \case + needed <- views _occurrencesScheduled . any $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart <= localTimeOfDay , localTimeOfDay <= scheduleEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.delete needle) - needle@ExceptOccur{..} -> do + throwE =<< asks (over _occurrencesExceptions $ Set.delete needle) + needle@ExceptOccurr{..} -> do let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay -- | Does this ExceptNoOccur target within needle? - withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime - && exceptTime <= LocalTime exceptDay exceptEnd + withinNeedle ExceptNoOccurr{..} = LocalTime exceptDay exceptStart <= exceptTime + && exceptTime <= LocalTime exceptDay exceptEnd withinNeedle _ = False - needed <- views _occurencesScheduled . none $ \case + needed <- views _occurrencesScheduled . none $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart == exceptStart , scheduleEnd == exceptEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 2d9b8b860..f3b8e0e7b 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -5,7 +5,7 @@ module Utils.PathPiece , splitCamel , camelToPathPiece, camelToPathPiece' , tuplePathPiece - , pathPieceJSONKey + , pathPieceJSON, pathPieceJSONKey ) where import ClassyPrelude.Yesod @@ -25,6 +25,7 @@ import Numeric.Natural import Data.List (foldl) import Data.Aeson.Types +import qualified Data.Aeson.Types as Aeson finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a @@ -120,5 +121,14 @@ pathPieceJSONKey tName = [d| instance ToJSONKey $(conT tName) where toJSONKey = toJSONKeyText toPathPiece instance FromJSONKey $(conT tName) where - fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t + fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t + |] + +pathPieceJSON :: Name -> DecsQ +-- ^ Derive `ToJSON`- and `FromJSON`-Instances from a `PathPiece`-Instance +pathPieceJSON tName + = [d| instance ToJSON $(conT tName) where + toJSON = Aeson.String . toPathPiece + instance FromJSON $(conT tName) where + parseJSON = Aeson.withText $(TH.lift $ nameBase tName) $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t |] diff --git a/templates/exam-list.hamlet b/templates/exam-list.hamlet new file mode 100644 index 000000000..b39bba56d --- /dev/null +++ b/templates/exam-list.hamlet @@ -0,0 +1,2 @@ +$newline never +^{examTable} diff --git a/templates/exam-new.hamlet b/templates/exam-new.hamlet new file mode 100644 index 000000000..2b87f350b --- /dev/null +++ b/templates/exam-new.hamlet @@ -0,0 +1,2 @@ +$newline never +^{newExamForm} diff --git a/templates/widgets/gradingKey.hamlet b/templates/widgets/gradingKey.hamlet new file mode 100644 index 000000000..d6a95326b --- /dev/null +++ b/templates/widgets/gradingKey.hamlet @@ -0,0 +1,15 @@ +$newline never + + + + + +
+ $forall g <- grades + + _{g} +
+ _{MsgGradingFrom} + $forall (_, fv) <- bounds + + ^{fvInput fv} diff --git a/templates/widgets/massinput/examCorrectors/add.hamlet b/templates/widgets/massinput/examCorrectors/add.hamlet new file mode 100644 index 000000000..bdf6da247 --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/add.hamlet @@ -0,0 +1,6 @@ +$newline never + + #{csrf} + ^{fvInput addView} + + ^{fvInput submitView} diff --git a/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet b/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet new file mode 100644 index 000000000..27c423ad1 --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/cellInvitation.hamlet @@ -0,0 +1,9 @@ +$newline never + + + #{email} + +
+
+
+ _{MsgEmailInvitationWarning} diff --git a/templates/widgets/massinput/examCorrectors/cellKnown.hamlet b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet new file mode 100644 index 000000000..5ea4cca6f --- /dev/null +++ b/templates/widgets/massinput/examCorrectors/cellKnown.hamlet @@ -0,0 +1,3 @@ +$newline never +
 + ^{nameEmailWidget userEmail userDisplayName userSurname} diff --git a/templates/widgets/occurence/form/scheduled-layout.hamlet b/templates/widgets/massinput/examCorrectors/layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-layout.hamlet rename to templates/widgets/massinput/examCorrectors/layout.hamlet diff --git a/templates/widgets/massinput/examParts/add.hamlet b/templates/widgets/massinput/examParts/add.hamlet new file mode 100644 index 000000000..6ef4903fb --- /dev/null +++ b/templates/widgets/massinput/examParts/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formWidget} + + ^{fvInput submitView} diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet new file mode 100644 index 000000000..2da5a3234 --- /dev/null +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -0,0 +1,4 @@ +$newline never +#{csrf}^{fvInput epfNameView} +^{fvInput epfMaxPointsView} +^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examParts/layout.hamlet b/templates/widgets/massinput/examParts/layout.hamlet new file mode 100644 index 000000000..87ab7fef4 --- /dev/null +++ b/templates/widgets/massinput/examParts/layout.hamlet @@ -0,0 +1,16 @@ +$newline never + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/examRooms/add.hamlet b/templates/widgets/massinput/examRooms/add.hamlet new file mode 100644 index 000000000..6ef4903fb --- /dev/null +++ b/templates/widgets/massinput/examRooms/add.hamlet @@ -0,0 +1,4 @@ +$newline never +^{formWidget} +
_{MsgExamPartName} + _{MsgExamPartMaxPoints} + _{MsgExamPartWeight} + +
+ ^{fvInput (delButtons ! coord)} +
+ ^{fvInput submitView} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet new file mode 100644 index 000000000..a6bdff401 --- /dev/null +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -0,0 +1,6 @@ +$newline never +#{csrf}^{fvInput eofRoomView} +^{fvInput eofCapacityView} +^{fvInput eofStartView} +^{fvInput eofEndView} +^{fvInput eofDescView} diff --git a/templates/widgets/massinput/examRooms/layout.hamlet b/templates/widgets/massinput/examRooms/layout.hamlet new file mode 100644 index 000000000..cc4211e5c --- /dev/null +++ b/templates/widgets/massinput/examRooms/layout.hamlet @@ -0,0 +1,18 @@ +$newline never + + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet index 2179c82b1..15911ac06 100644 --- a/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet +++ b/templates/widgets/massinput/uploadSpecificFiles/layout.hamlet @@ -4,7 +4,7 @@ $newline never $forall coord <- review liveCoords lLength diff --git a/templates/widgets/occurence/cell.hamlet b/templates/widgets/occurrence/cell.hamlet similarity index 64% rename from templates/widgets/occurence/cell.hamlet rename to templates/widgets/occurrence/cell.hamlet index bb1f1f3d7..295b3ae24 100644 --- a/templates/widgets/occurence/cell.hamlet +++ b/templates/widgets/occurrence/cell.hamlet @@ -1,12 +1,12 @@ $newline never
    - $forall sched <- occurencesScheduled' + $forall sched <- occurrencesScheduled'
  • ^{sched} -$if not (null occurencesExceptions) +$if not (null occurrencesExceptions) $#
    $#
    $#
      - $forall exc <- occurencesExceptions' + $forall exc <- occurrencesExceptions'
    • ^{exc} diff --git a/templates/widgets/occurence/cell/except-no-occur.hamlet b/templates/widgets/occurrence/cell/except-no-occurr.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-no-occur.hamlet rename to templates/widgets/occurrence/cell/except-no-occurr.hamlet diff --git a/templates/widgets/occurence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occurr.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-occur.hamlet rename to templates/widgets/occurrence/cell/except-occurr.hamlet diff --git a/templates/widgets/occurence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/cell/weekly.hamlet rename to templates/widgets/occurrence/cell/weekly.hamlet diff --git a/templates/widgets/occurence/form/except-add.hamlet b/templates/widgets/occurrence/form/except-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-add.hamlet rename to templates/widgets/occurrence/form/except-add.hamlet diff --git a/templates/widgets/occurrence/form/except-layout.hamlet b/templates/widgets/occurrence/form/except-layout.hamlet new file mode 100644 index 000000000..65352dd95 --- /dev/null +++ b/templates/widgets/occurrence/form/except-layout.hamlet @@ -0,0 +1,11 @@ +$newline never +
_{MsgExamRoom} + _{MsgExamRoomCapacity} + _{MsgExamRoomStart} + _{MsgExamRoomEnd} + _{MsgExamRoomDescription} + +
+ ^{fvInput (delButtons ! coord)} +
_{MsgUploadSpecificFileLabel} _{MsgUploadSpecificFileName} _{MsgUploadSpecificFileRequired} - +
+ + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/occurence/form/except-no-occur.hamlet b/templates/widgets/occurrence/form/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-no-occur.hamlet rename to templates/widgets/occurrence/form/except-no-occur.hamlet diff --git a/templates/widgets/occurence/form/except-occur.hamlet b/templates/widgets/occurrence/form/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-occur.hamlet rename to templates/widgets/occurrence/form/except-occur.hamlet diff --git a/templates/widgets/occurrence/form/scheduled-add.hamlet b/templates/widgets/occurrence/form/scheduled-add.hamlet new file mode 100644 index 000000000..bcb16ecfa --- /dev/null +++ b/templates/widgets/occurrence/form/scheduled-add.hamlet @@ -0,0 +1,5 @@ +$newline never +
+ ^{fvInput (delButtons ! coord)} +
+ ^{addWidget} + + ^{fvInput submitView} diff --git a/templates/widgets/occurrence/form/scheduled-layout.hamlet b/templates/widgets/occurrence/form/scheduled-layout.hamlet new file mode 100644 index 000000000..65352dd95 --- /dev/null +++ b/templates/widgets/occurrence/form/scheduled-layout.hamlet @@ -0,0 +1,11 @@ +$newline never + + + $forall coord <- review liveCoords lLength + + ^{cellWdgts ! coord} + + + ^{addWdgts ! (0, 0)} diff --git a/templates/widgets/occurence/form/weekly.hamlet b/templates/widgets/occurrence/form/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/form/weekly.hamlet rename to templates/widgets/occurrence/form/weekly.hamlet diff --git a/test/Database.hs b/test/Database.hs index ea044ac75..f339ee6d0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -586,9 +586,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now @@ -604,9 +604,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now From d054370b29b5098c7dad1e0360c5cf24e205b48d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 12 Jun 2019 09:17:32 +0200 Subject: [PATCH 04/17] Better exam table --- messages/uniworx/de.msg | 1 + routes | 3 ++- src/Foundation.hs | 11 +++++++++++ src/Handler/Exam.hs | 19 +++++++++++++++---- src/Handler/Utils/Exam.hs | 10 +++++----- 5 files changed, 34 insertions(+), 10 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 530f07b25..5dfe93c8c 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -278,6 +278,7 @@ UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedMaterialTime: Dieses Material ist momentan nicht freigegeben. UnauthorizedTutorialTime: Dieses Tutorium erlaubt momentan keine Anmeldungen. +UnauthorizedExamTime: Diese Klausur ist momentan nicht freigegeben. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. diff --git a/routes b/routes index f409deb1d..17d24e02c 100644 --- a/routes +++ b/routes @@ -137,9 +137,10 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST - /exams CExamListR GET !development -- Missing permission checks on which exams can be shown + /exams CExamListR GET !free /exams/new CExamNewR GET POST /exams/#ExamName ExamR: + /show EShowR GET !time /corrector-invite ECInviteR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index dc3621858..2808e6180 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -641,6 +641,15 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do + course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh + Entity _ Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn + cTime <- liftIO getCurrentTime + + guard $ NTop examVisibleFrom <= NTop (Just cTime) + + return Authorized + CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do now <- liftIO getCurrentTime course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -1446,6 +1455,8 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CExamListR) = return ("Klausuren", Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) + breadcrumb (CExamR tid ssh csh examn EShowR) = return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) + breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) breadcrumb (CTutorialR tid ssh csh tutn TDeleteR) = return ("Löschen", Just $ CTutorialR tid ssh csh tutn TUsersR) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 4f1c4917a..5def10ff3 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -7,6 +7,7 @@ import Import import Handler.Utils import Handler.Utils.Exam import Handler.Utils.Invitations +import Handler.Utils.Table.Cells import Jobs.Queue import Utils.Lens @@ -25,6 +26,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml) getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh + now <- liftIO getCurrentTime + mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR let examDBTable = DBTable{..} @@ -33,10 +36,15 @@ getCExamListR tid ssh csh = do E.where_ $ exam E.^. ExamCourse E.==. E.val cid return exam dbtRowKey = (E.^. ExamId) - dbtProj = return - dbtColonnade = dbColonnade $ mconcat - [ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ toWidget examName - , sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> cell $ do + dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = 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 + , (<$ 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| @@ -389,3 +397,6 @@ postCExamNewR tid ssh csh = do , formEncoding = newExamEnctype } $(widgetFile "exam-new") + +getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEShowR = error "getExamShowR" diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 249d98b73..3d1d43845 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -3,7 +3,7 @@ module Handler.Utils.Exam , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam ) where -import Import +import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E @@ -34,14 +34,14 @@ fetchExamAux prj tid ssh csh examn = [tut] -> return tut _other -> notFound -fetchExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> DB (Entity Exam) +fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam) fetchExam = fetchExamAux const -fetchExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Exam) +fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam) fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn -fetchCourseIdExamId :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Key Exam) +fetchCourseIdExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam) fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn -fetchCourseIdExam :: TermId -> SchoolId -> CourseShorthand -> ExamName -> YesodDB UniWorX (Key Course, Entity Exam) +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 From 67a50c9e87d3368aafe7f52a3b81e580713e6c24 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Jun 2019 15:34:09 +0200 Subject: [PATCH 05/17] feat(exams): CRU (no D) for exams --- messages/uniworx/de.msg | 26 +- models/exams | 14 +- routes | 1 + src/CryptoID.hs | 2 + src/Foundation.hs | 26 +- src/Handler/Course.hs | 43 +++ src/Handler/Exam.hs | 309 +++++++++++++++++- src/Handler/Tutorial.hs | 2 +- src/Handler/Utils/Form.hs | 3 +- src/Model.hs | 1 + src/Model/Types/Exam.hs | 22 +- src/Utils/Lens.hs | 2 + templates/course.hamlet | 4 + templates/exam-edit.hamlet | 2 + templates/exam-show.cassius | 6 + templates/exam-show.hamlet | 149 +++++++++ templates/widgets/bonusRule.hamlet | 8 + templates/widgets/gradingKey.hamlet | 4 +- .../widgets/massinput/examParts/form.hamlet | 2 +- .../widgets/massinput/examRooms/form.hamlet | 2 +- 20 files changed, 599 insertions(+), 29 deletions(-) create mode 100644 templates/exam-edit.hamlet create mode 100644 templates/exam-show.cassius create mode 100644 templates/exam-show.hamlet create mode 100644 templates/widgets/bonusRule.hamlet diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 5dfe93c8c..0594a3462 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -839,6 +839,7 @@ MenuTutorialEdit: Tutorium editieren MenuTutorialComm: Mitteilung an Teilnehmer MenuExamList: Klausuren MenuExamNew: Neue Klausur anlegen +MenuExamEdit: Bearbeiten AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -979,6 +980,7 @@ TutorialsHeading: Tutorien TutorialEdit: Bearbeiten TutorialDelete: Löschen +CourseExams: Klausuren CourseTutorials: Übungen ParticipantsN n@Int: Teilnehmer @@ -1000,6 +1002,7 @@ TutorialNew: Neues Tutorium TutorialNameTaken tutn@TutorialName: Es existiert bereits anderes Tutorium mit Namen #{tutn} TutorialCreated tutn@TutorialName: Tutorium #{tutn} erfolgreich angelegt +TutorialEdited tutn@TutorialName: Tutiorium #{tutn} erfolgreich bearbeitet TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten @@ -1037,10 +1040,14 @@ ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klaus ExamRegisterTo: Anmeldung bis ExamDeregisterUntil: Abmeldung bis ExamPublishOccurrenceAssignments: Terminzuteilung den Teilnehmern mitteilen um +ExamPublishOccurrenceAssignmentsParticipant: Terminzuteilung einsehbar ab ExamFinished: Bewertung abgeschlossen ab +ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen ExamFinishedTip: Zeitpunkt zu dem Klausurergebnisse den Teilnehmern gemeldet werden ExamClosed: Noten stehen fest ab ExamClosedTip: Zeitpunkt ab dem keine Änderungen an den Ergebnissen zulässig sind; Prüfungsämter bekommen Einsicht +ExamShowGrades: Noten anzeigen +ExamShowGradesTip: Soll den Teilnehmern ihre genaue Note angezeigt werden, oder sollen sie nur informiert werden, ob sie bestanden haben? ExamPublicStatistics: Statistik veröffentlichen ExamPublicStatisticsTip: Soll die statistische Auswertung auch den Teilnehmer angezeigt werden, sobald diese ihre Noten einsehen können? ExamGradingRule: Notenberechnung @@ -1057,11 +1064,14 @@ ExamBonusRule: Klausurbonus aus Übungsbetrieb ExamNoBonus': Kein Bonus ExamBonusPoints': Umrechnung von Übungspunkten +ExamEditHeading examn@ExamName: #{examn} bearbeiten + 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 ExamRoomManual': Keine automatische Zuteilung ExamRoomSurname': Nach Nachname ExamRoomMatriculation': Nach Matrikelnummer @@ -1072,10 +1082,12 @@ ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoom: Raum ExamRoomCapacity: Kapazität ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein +ExamRoomTime: Termin ExamRoomStart: Beginn ExamRoomEnd: Ende ExamRoomDescription: Beschreibung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfung +ExamRoomRegistered: Zugeteilt ExamFormTimes: Zeiten ExamFormOccurrences: Prüfungstermine @@ -1092,6 +1104,18 @@ ExamPartAlreadyExists: Teilaufgabe mit diesem Namen existiert bereits ExamPartName: Name ExamPartMaxPoints: Maximalpunktzahl ExamPartWeight: Gewichtung +ExamPartResultPoints: Erreichte Punkte ExamNameTaken exam@ExamName: Es existiert bereits eine Klausur mit Namen #{exam} -ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt \ No newline at end of file +ExamCreated exam@ExamName: Klausur #{exam} erfolgreich angelegt +ExamEdited exam@ExamName: Klausur #{exam} erfolgreich bearbeitet + +ExamNoShow: Nicht erschienen +ExamVoided: Entwertet + +ExamBonusPoints possible@Points: Maximal #{showFixed True possible} Klausurpunkte +ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Klausurpunkte, falls die Klausur auch ohne Bonus bereits bestanden ist + +ExamPassed: Bestanden +ExamNotPassed: Nicht bestanden +ExamResult: Klausurergebnis \ No newline at end of file diff --git a/models/exams b/models/exams index b6ed523e2..365862929 100644 --- a/models/exams +++ b/models/exams @@ -14,6 +14,7 @@ Exam finished UTCTime Maybe -- Grades shown to students, `ExamCorrector`s locked out closed UTCTime Maybe -- Prüfungsamt hat Einsicht (notification) publicStatistics Bool + showGrades Bool description Html Maybe UniqueExam course name ExamPart @@ -32,13 +33,18 @@ ExamOccurrence ExamRegistration exam ExamId user UserId - occurance ExamOccurrenceId Maybe + occurrence ExamOccurrenceId Maybe UniqueExamRegistration exam user -ExamResult +ExamPartResult examPart ExamPartId user UserId - result ExamPartResult - UniqueExamResult examPart user + result ExamResultPoints + UniqueExamPartResult examPart user +ExamResult + exam ExamId + user UserId + result ExamResultGrade + UniqueExamResult exam user ExamCorrector exam ExamId user UserId diff --git a/routes b/routes index 17d24e02c..9d35caa33 100644 --- a/routes +++ b/routes @@ -141,6 +141,7 @@ /exams/new CExamNewR GET POST /exams/#ExamName ExamR: /show EShowR GET !time + /edit EEditR GET POST /corrector-invite ECInviteR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 59b925060..f170302a0 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -43,6 +43,8 @@ decCryptoIDs [ ''SubmissionId , ''SystemMessageId , ''SystemMessageTranslationId , ''StudyFeaturesId + , ''ExamOccurrenceId + , ''ExamPartId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index 2808e6180..84bac443b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1456,6 +1456,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR) breadcrumb (CExamR tid ssh csh examn EShowR) = return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) + breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR) breadcrumb (CTutorialR tid ssh csh tutn TUsersR) = return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) breadcrumb (CTutorialR tid ssh csh tutn TEditR) = return ("Bearbeiten", Just $ CTutorialR tid ssh csh tutn TUsersR) @@ -1885,7 +1886,7 @@ pageActions (CourseR tid ssh csh CShowR) = E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return $ sheet E.^. SheetName - anyM sheetNames (sheetAccess . E.unValue) + anyM sheetNames $ sheetAccess . E.unValue in runDB $ lecturerAccess `or2M` existsVisible } ] ++ pageActions (CourseR tid ssh csh SheetListR) ++ @@ -1903,7 +1904,18 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemIcon = Nothing , menuItemRoute = SomeRoute $ CourseR tid ssh csh CExamListR , menuItemModal = False - , menuItemAccessCallback' = return True + , menuItemAccessCallback' = + let lecturerAccess = hasWriteAccessTo $ CourseR tid ssh csh CExamNewR + examAccess examn = hasReadAccessTo $ CExamR tid ssh csh examn EShowR + existsVisible = do + examNames <- E.select . E.from $ \(course `E.InnerJoin` exam) -> do + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return $ exam E.^. ExamName + anyM examNames $ examAccess . E.unValue + in runDB $ lecturerAccess `or2M` existsVisible } , MenuItem { menuItemType = PageActionSecondary @@ -2119,6 +2131,16 @@ pageActions (CourseR tid ssh csh CExamListR) = , menuItemAccessCallback' = return True } ] +pageActions (CExamR tid ssh csh examn EShowR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuExamEdit + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CExamR tid ssh csh examn EEditR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (CSheetR tid ssh csh shn SShowR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index c31b7048c..f849fb282 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -407,6 +407,49 @@ getCShowR tid ssh csh = do & defaultSorting [SortAscBy "type", SortAscBy "name"] (Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable + let + examDBTable = DBTable{..} + where + dbtSQLQuery exam = do + E.where_ $ exam E.^. ExamCourse E.==. E.val cid + return exam + dbtRowKey = (E.^. ExamId) + dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = 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 "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'} + |] + + ] + dbtSorting = Map.fromList + [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) + , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) + , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) + , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) + , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) + ] + dbtFilter = Map.empty + dbtFilterUI = const mempty + dbtStyle = def + dbtParams = def + dbtIdent :: Text + dbtIdent = "exams" + + examDBTableValidator = def + & defaultSorting [SortAscBy "time"] + (Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable + siteLayout (toWgt $ courseName course) $ do setTitleI $ prependCourseTitle tid ssh csh (""::Text) $(widgetFile "course") diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 5def10ff3..dffde8e32 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -10,11 +10,12 @@ import Handler.Utils.Invitations import Handler.Utils.Table.Cells import Jobs.Queue -import Utils.Lens +import Utils.Lens hiding (parts) import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E -import Data.Map ((!)) +import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set @@ -22,6 +23,8 @@ import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) import Text.Blaze.Html.Renderer.String (renderHtml) +import qualified Data.CaseInsensitive as CI + getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do @@ -57,6 +60,9 @@ getCExamListR tid ssh csh = do dbtSorting = Map.fromList [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) , ("time", SortColumn $ \exam -> exam E.^. ExamStart ) + , ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom ) + , ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo ) + , ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom ) ] dbtFilter = Map.empty dbtFilterUI = const mempty @@ -147,6 +153,7 @@ data ExamForm = ExamForm , efFinished :: Maybe UTCTime , efClosed :: Maybe UTCTime , efOccurrences :: Set ExamOccurrenceForm + , efShowGrades :: Bool , efPublicStatistics :: Bool , efGradingRule :: ExamGradingRule , efBonusRule :: ExamBonusRule @@ -156,7 +163,8 @@ data ExamForm = ExamForm } data ExamOccurrenceForm = ExamOccurrenceForm - { eofRoom :: Text + { eofId :: Maybe CryptoUUIDExamOccurrence + , eofRoom :: Text , eofCapacity :: Natural , eofStart :: UTCTime , eofEnd :: Maybe UTCTime @@ -164,7 +172,8 @@ data ExamOccurrenceForm = ExamOccurrenceForm } deriving (Read, Show, Eq, Ord, Generic, Typeable) data ExamPartForm = ExamPartForm - { epfName :: ExamPartName + { epfId :: Maybe CryptoUUIDExamPart + , epfName :: ExamPartName , epfMaxPoints :: Maybe Points , epfWeight :: Rational } deriving (Read, Show, Eq, Ord, Generic, Typeable) @@ -198,6 +207,7 @@ examForm template html = do <* aformSection MsgExamFormOccurrences <*> examOccurrenceForm (efOccurrences <$> template) <* aformSection MsgExamFormAutomaticFunctions + <*> (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) @@ -263,6 +273,7 @@ examOccurrenceForm prev = wFormToAForm $ do fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) True $ 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) (eofCapacityRes, eofCapacityView) <- mpreq (posIntFieldI MsgExamRoomCapacityNonPositive) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev) (eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev) @@ -270,7 +281,8 @@ examOccurrenceForm prev = wFormToAForm $ do (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) return ( ExamOccurrenceForm - <$> eofRoomRes + <$> eofIdRes + <*> eofRoomRes <*> eofCapacityRes <*> eofStartRes <*> eofEndRes @@ -301,12 +313,14 @@ examPartsForm prev = wFormToAForm $ do fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) True $ Set.toList <$> prev where examPartForm' nudge mPrev csrf = do + (epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev) (epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev) (epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev) (epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1) return ( ExamPartForm - <$> epfNameRes + <$> epfIdRes + <*> epfNameRes <*> epfMaxPointsRes <*> epfWeightRes , $(widgetFile "widgets/massinput/examParts/form") @@ -325,12 +339,114 @@ examPartsForm prev = wFormToAForm $ do miIdent' :: Text miIdent' = "exam-parts" +examFormTemplate :: Entity Exam -> DB ExamForm +examFormTemplate (Entity eId Exam{..}) = do + parts <- selectList [ ExamPartExam ==. eId ] [] + occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] + correctors <- selectList [ ExamCorrectorExam ==. eId ] [] + invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId + + parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part + occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ + + return ExamForm + { efName = examName + , efGradingRule = examGradingRule + , efBonusRule = examBonusRule + , efOccurrenceRule = examOccurrenceRule + , efVisibleFrom = examVisibleFrom + , efRegisterFrom = examRegisterFrom + , efRegisterTo = examRegisterTo + , efDeregisterUntil = examDeregisterUntil + , efPublishOccurrenceAssignments = examPublishOccurrenceAssignments + , efStart = examStart + , efEnd = examEnd + , efFinished = examFinished + , efClosed = examClosed + , efShowGrades = examShowGrades + , efPublicStatistics = examPublicStatistics + , efDescription = examDescription + , efOccurrences = Set.fromList $ do + (Just -> eofId, ExamOccurrence{..}) <- occurrences' + return ExamOccurrenceForm + { eofId + , eofRoom = examOccurrenceRoom + , eofCapacity = examOccurrenceCapacity + , eofStart = examOccurrenceStart + , eofEnd = examOccurrenceEnd + , eofDescription = examOccurrenceDescription + } + , efExamParts = Set.fromList $ do + (Just -> epfId, ExamPart{..}) <- parts' + return ExamPartForm + { epfId + , epfName = examPartName + , epfMaxPoints = examPartMaxPoints + , epfWeight = examPartWeight + } + , efCorrectors = Set.unions + [ Set.fromList $ map Left invitations + , Set.fromList . map Right $ do + Entity _ ExamCorrector{..} <- correctors + return examCorrectorUser + ] + } + +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) + E.||. course E.^. CourseName E.==. E.val (courseName newCourse) + ) + E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse) + E.where_ . E.not_ . E.exists . E.from $ \exam' -> do + E.where_ $ exam' E.^. ExamCourse E.==. E.val cid + E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName + E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom + E.limit 1 + E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] + return (course, exam) + + oldTerm <- MaybeT . get $ courseTerm oldCourse + newTerm <- MaybeT . get $ courseTerm newCourse + + let + dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm + + return ExamForm + { efName = examName oldExam + , efGradingRule = examGradingRule oldExam + , efBonusRule = examBonusRule oldExam + , efOccurrenceRule = examOccurrenceRule oldExam + , efVisibleFrom = dateOffset <$> examVisibleFrom oldExam + , efRegisterFrom = dateOffset <$> examRegisterFrom oldExam + , efRegisterTo = dateOffset <$> examRegisterTo oldExam + , efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam + , efPublishOccurrenceAssignments = dateOffset $ examPublishOccurrenceAssignments oldExam + , efStart = dateOffset $ examStart oldExam + , efEnd = dateOffset <$> examEnd oldExam + , efFinished = dateOffset <$> examFinished oldExam + , efClosed = dateOffset <$> examClosed oldExam + , efShowGrades = examShowGrades oldExam + , efPublicStatistics = examPublicStatistics oldExam + , efDescription = examDescription oldExam + , efOccurrences = Set.empty + , efExamParts = Set.empty + , efCorrectors = Set.empty + } + getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR postCExamNewR tid ssh csh = do - cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + (cid, template) <- runDB $ do + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh + template <- examTemplate cid + return (cid, template) - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm Nothing + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm template formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do @@ -349,6 +465,7 @@ postCExamNewR tid ssh csh = do , examEnd = efEnd , examFinished = efFinished , examClosed = efClosed + , examShowGrades = efShowGrades , examPublicStatistics = efPublicStatistics , examDescription = efDescription } @@ -398,5 +515,179 @@ postCExamNewR tid ssh csh = do } $(widgetFile "exam-new") +getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEEditR = postEEditR +postEEditR tid ssh csh examn = do + (cid, eId, template) <- runDB $ do + (cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn + + template <- examFormTemplate exam + + return (cid, eId, template) + + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . examForm $ Just template + + formResult editExamResult $ \ExamForm{..} -> do + insertRes <- runDBJobs $ do + insertRes <- myReplaceUnique eId Exam + { examCourse = cid + , examName = efName + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = efClosed + , examPublicStatistics = efPublicStatistics + , examShowGrades = efShowGrades + , examDescription = efDescription + } + + when (is _Nothing insertRes) $ do + occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId + deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ] + forM_ (Set.toList efOccurrences) $ \case + ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_ + ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceRoom = eofRoom + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } + ExamOccurrenceForm{ .. } -> void . runMaybeT $ do + cID <- hoistMaybe eofId + eofId' <- decrypt cID + oldOcc <- MaybeT $ get eofId' + guard $ examOccurrenceExam oldOcc == eId + lift $ replace eofId' ExamOccurrence + { examOccurrenceExam = eId + , examOccurrenceRoom = eofRoom + , examOccurrenceCapacity = eofCapacity + , examOccurrenceStart = eofStart + , examOccurrenceEnd = eofEnd + , examOccurrenceDescription = eofDescription + } + + + pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId + deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] + forM_ (Set.toList efExamParts) $ \case + ExamPartForm{ epfId = Nothing, .. } -> insert_ + ExamPart + { examPartExam = eId + , examPartName = epfName + , examPartMaxPoints = epfMaxPoints + , examPartWeight = epfWeight + } + ExamPartForm{ .. } -> void . runMaybeT $ do + cID <- hoistMaybe epfId + epfId' <- decrypt cID + oldPart <- MaybeT $ get epfId' + guard $ examPartExam oldPart == eId + lift $ replace epfId' ExamPart + { examPartExam = eId + , examPartName = epfName + , examPartMaxPoints = epfMaxPoints + , examPartWeight = epfWeight + } + + + let (invites, adds) = partitionEithers $ Set.toList efCorrectors + + deleteWhere [ ExamCorrectorExam ==. eId ] + insertMany_ $ map (ExamCorrector eId) adds + + deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] + sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites + + return insertRes + + case insertRes of + Just _ -> addMessageI Error $ MsgExamNameTaken efName + Nothing -> do + addMessageI Success $ MsgExamEdited efName + redirect $ CExamR tid ssh csh efName EShowR + + let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template + + siteLayoutMsg heading $ do + setTitleI heading + let + editExamForm = wrapForm editExamWidget def + { formMethod = POST + , formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR + , formEncoding = editExamEnctype + } + $(widgetFile "exam-edit") + + getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html -getEShowR = error "getExamShowR" +getEShowR tid ssh csh examn = do + cTime <- liftIO getCurrentTime + mUid <- maybeAuthId + + (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) <- runDB $ do + exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn + + let examVisible = NTop (Just cTime) >= NTop examVisibleFrom + + let gradingVisible = NTop (Just cTime) >= NTop examFinished + gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + let occurrenceAssignmentsVisible = cTime >= examPublishOccurrenceAssignments + occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR + + parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ] + + resultsRaw <- for mUid $ \uid -> + E.select . E.from $ \examPartResult -> do + E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid + E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts) + return examPartResult + let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw + + result <- fmap join . for mUid $ getBy . UniqueExamResult eId + + occurrencesRaw <- E.select . E.from $ \examOccurrence -> do + E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId + let + registered + | Just uid <- mUid + = E.exists . E.from $ \examRegistration -> do + E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId + E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid + E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId) + | otherwise = E.false + E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom] + return (examOccurrence, registered) + + let occurrences = map (over _2 E.unValue) occurrencesRaw + + return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) + + let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + + let heading = prependCourseTitle tid ssh csh $ CI.original examName + + siteLayoutMsg heading $ do + setTitleI heading + let + gradingKeyW :: [Points] -> Widget + gradingKeyW bounds + = let boundWidgets :: [Widget] + boundWidgets = map (toWidget . (pack :: String -> Text) . showFixed True) bounds + grades :: [ExamGrade] + grades = universeF + in $(widgetFile "widgets/gradingKey") + + examBonusW :: ExamBonusRule -> Widget + examBonusW bonusRule = $(widgetFile "widgets/bonusRule") + $(widgetFile "exam-show") diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 964dfa1b3..2ae2172f7 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -456,7 +456,7 @@ postTEditR tid ssh csh tutn = do case insertRes of Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName Nothing -> do - addMessageI Success $ MsgTutorialCreated tfName + addMessageI Success $ MsgTutorialEdited tfName redirect $ CourseR tid ssh csh CTutorialListR let heading = prependCourseTitle tid ssh csh . MsgTutorialEditHeading $ tfName template diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ea6d929b3..f35c0a7c1 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -559,7 +559,8 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas { fvLabel = toMarkup $ mr fsLabel , fvTooltip = toMarkup . mr <$> fsTooltip , fvId - , fvInput = $(widgetFile "widgets/gradingKey") + , fvInput = let boundWidgets = map (fvInput . snd) bounds + in $(widgetFile "widgets/gradingKey") , fvErrors = if | (e : _) <- errors -> Just $ toMarkup e | otherwise -> Nothing diff --git a/src/Model.hs b/src/Model.hs index c86406275..45ce97e6d 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -35,6 +35,7 @@ deriving instance Eq (Unique Course) -- instance Eq TermSchoolCourseShort; in deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial +deriving instance Eq (Unique Exam) submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 1f8d5876f..1608c7311 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE UndecidableInstances #-} + {-| Module: Model.Types.Exam Description: Types for modeling Exams @@ -11,17 +13,17 @@ import Model.Types.Common import Control.Lens -data ExamPartResult = ExamAttended { examPartResult :: Maybe Points } - | ExamNoShow - | ExamVoided +data ExamResult' res = ExamAttended { examResult :: res } + | ExamNoShow + | ExamVoided deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 - , fieldLabelModifier = camelToPathPiece' 2 + , fieldLabelModifier = camelToPathPiece' 1 , omitNothingFields = True , sumEncoding = TaggedObject "status" "result" - } ''ExamPartResult -derivePersistFieldJSON ''ExamPartResult + } ''ExamResult' +derivePersistFieldJSON ''ExamResult' data ExamBonusRule = ExamNoBonus | ExamBonusPoints @@ -94,12 +96,15 @@ numberGrade = prism toNumberGrade fromNumberGrade n -> Left n instance PathPiece ExamGrade where - toPathPiece = tshow . review numberGrade + toPathPiece = tshow . (fromRational :: Rational -> Deci) . review numberGrade fromPathPiece = finiteFromPathPiece pathPieceJSON ''ExamGrade pathPieceJSONKey ''ExamGrade +passingGrade :: ExamGrade -> Bool +passingGrade = (>= Grade40) + data ExamGradingRule = ExamGradingManual | ExamGradingKey @@ -112,3 +117,6 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "rule" "settings" } ''ExamGradingRule derivePersistFieldJSON ''ExamGradingRule + +type ExamResultPoints = ExamResult' (Maybe Points) +type ExamResultGrade = ExamResult' ExamGrade diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 955b7dcf6..a6f14183a 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -126,6 +126,8 @@ makeLenses_ ''PredDNF makeLenses_ ''ExamBonusRule makeLenses_ ''ExamGradingRule +makeLenses_ ''UTCTime + -- makeClassy_ ''Load diff --git a/templates/course.hamlet b/templates/course.hamlet index 93d788a26..c416e0efc 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -93,6 +93,10 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) $else Eine Anmeldung zum Kurs ist Voraussetzung zum Zugang zu Kursmaterial (z.B. Übungsblätter). + $if hasExams +
_{MsgCourseExams} +
+ ^{examTable} $if hasTutorials
_{MsgCourseTutorials}
diff --git a/templates/exam-edit.hamlet b/templates/exam-edit.hamlet new file mode 100644 index 000000000..e11d0926b --- /dev/null +++ b/templates/exam-edit.hamlet @@ -0,0 +1,2 @@ +$newline never +^{editExamForm} diff --git a/templates/exam-show.cassius b/templates/exam-show.cassius new file mode 100644 index 000000000..b0f051fcb --- /dev/null +++ b/templates/exam-show.cassius @@ -0,0 +1,6 @@ +.occurrence--not-registered + text-decoration: strike-through; + +.result + padding-left: 2em; + font-size: 20px; diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet new file mode 100644 index 000000000..36625be20 --- /dev/null +++ b/templates/exam-show.hamlet @@ -0,0 +1,149 @@ +$newline never +$maybe Entity _ ExamResult{examResultResult} <- result + $if gradingShown +
+

+ _{MsgExamResult} + $if gradingShown && not gradingVisible + \ ^{isVisible False} +

+ $case examResultResult + $of ExamAttended grade + $if examShowGrades + _{grade} + $else + $if passingGrade grade + _{MsgExamPassed} + $else + _{MsgExamNotPassed} + $of ExamNoShow + _{MsgExamNoShow} + $of ExamVoided + _{MsgExamVoided} + +$maybe desc <- examDescription +

+ #{desc} + +
+
+ $if not examVisible +
_{MsgExamVisibleFrom} +
+ $maybe from <- examVisibleFrom + ^{formatTimeW SelFormatDateTime from} + $nothing + _{MsgNever} + \ ^{isVisible False} + $maybe regFrom <- examRegisterFrom +
_{MsgExamRegisterFrom} +
^{formatTimeW SelFormatDateTime regFrom} + $maybe regTo <- examRegisterTo +
_{MsgExamRegisterTo} +
^{formatTimeW SelFormatDateTime regTo} + $maybe deregUntil <- examDeregisterUntil +
_{MsgExamDeregisterUntil} +
^{formatTimeW SelFormatDateTime deregUntil} +
_{MsgExamPublishOccurrenceAssignmentsParticipant} +
^{formatTimeW SelFormatDateTime examPublishOccurrenceAssignments} + $if examTimes +
_{MsgExamTime} +
+ ^{formatTimeW SelFormatDateTime examStart} + $maybe end <- examEnd + \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end} + $maybe finished <- examFinished +
_{MsgExamFinishedParticipant} +
^{formatTimeW SelFormatDateTime finished} + $if gradingShown + $if examGradingRule /= ExamGradingManual +
+ _{MsgExamGradingRule} + $if not gradingVisible + \ ^{isVisible False} +
+ $case examGradingRule + $of ExamGradingManual + _{MsgExamGradingManual'} + $of ExamGradingKey{..} + ^{gradingKeyW examGradingKey} + $if examBonusRule /= ExamNoBonus +
+ _{MsgExamBonusRule} + $if not gradingVisible + \ ^{isVisible False} +
+ ^{examBonusW examBonusRule} + $if occurrenceAssignmentsShown +
+ _{MsgExamOccurrenceRuleParticipant} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} +
+ $# TODO + +$if not (null occurrences) +
+

+ _{MsgExamOccurrences} +

+ ^{fvInput (delButtons ! coord)} +
+ + + + $forall (Entity _occId ExamOccurrence{examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription}, registered) <- occurrences + +
_{MsgExamRoom} + $if not examTimes + _{MsgExamRoomTime} + _{MsgExamRoomDescription} + $if occurrenceAssignmentsShown + + _{MsgExamRoomRegistered} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} +
#{examOccurrenceRoom} + $if not examTimes + + ^{formatTimeW SelFormatDateTime examOccurrenceStart} + $maybe end <- examOccurrenceEnd + \ – ^{formatTimeW (bool SelFormatDateTime SelFormatTime ((on (==) utctDay) examStart end)) end} + + $maybe desc <- examOccurrenceDescription + #{desc} + $if occurrenceAssignmentsShown + + $if registered + #{fontAwesomeIcon "check"} + +$if gradingShown && not (null parts) +
+

+ _{MsgExamParts} + $if gradingShown && not gradingVisible + \ ^{isVisible False} + + + + + $forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- parts + +
_{MsgExamPartName} + _{MsgExamPartMaxPoints} + _{MsgExamPartResultPoints} +
#{examPartName} + + $maybe mPoints <- examPartMaxPoints + #{showFixed True (fromRational examPartWeight * mPoints)} + + $case fmap (examPartResultResult . entityVal) (results !? partId) + $of Nothing + $of Just (ExamAttended (Just ps)) + #{showFixed True ps} + $of Just (ExamAttended Nothing) + #{fontAwesomeIcon "check"} + $of Just ExamNoShow + _{MsgExamNoShow} + $of Just ExamVoided + _{MsgExamVoided} + +$# TODO: Statistics diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet new file mode 100644 index 000000000..bf72b1684 --- /dev/null +++ b/templates/widgets/bonusRule.hamlet @@ -0,0 +1,8 @@ +$newline never +$case bonusRule + $of ExamNoBonus + _{MsgExamNoBonus'} + $of ExamBonusPoints ps False + _{MsgExamBonusPoints ps} + $of ExamBonusPoints ps True + _{MsgExamBonusPointsPassed ps} diff --git a/templates/widgets/gradingKey.hamlet b/templates/widgets/gradingKey.hamlet index d6a95326b..e035911e1 100644 --- a/templates/widgets/gradingKey.hamlet +++ b/templates/widgets/gradingKey.hamlet @@ -10,6 +10,6 @@ $newline never
_{MsgGradingFrom} - $forall (_, fv) <- bounds + $forall w <- boundWidgets - ^{fvInput fv} + ^{w} diff --git a/templates/widgets/massinput/examParts/form.hamlet b/templates/widgets/massinput/examParts/form.hamlet index 2da5a3234..0ef5c4f7a 100644 --- a/templates/widgets/massinput/examParts/form.hamlet +++ b/templates/widgets/massinput/examParts/form.hamlet @@ -1,4 +1,4 @@ $newline never -#{csrf}^{fvInput epfNameView} +#{csrf}^{fvInput epfIdView}^{fvInput epfNameView} ^{fvInput epfMaxPointsView} ^{fvInput epfWeightView} diff --git a/templates/widgets/massinput/examRooms/form.hamlet b/templates/widgets/massinput/examRooms/form.hamlet index a6bdff401..bd0fd06ed 100644 --- a/templates/widgets/massinput/examRooms/form.hamlet +++ b/templates/widgets/massinput/examRooms/form.hamlet @@ -1,5 +1,5 @@ $newline never -#{csrf}^{fvInput eofRoomView} +#{csrf}^{fvInput eofIdView}^{fvInput eofRoomView} ^{fvInput eofCapacityView} ^{fvInput eofStartView} ^{fvInput eofEndView} From 99184ff05322573a6958f09e30fa0fdcdd3d665b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Jun 2019 15:25:59 +0200 Subject: [PATCH 06/17] feat(exams): exam registration --- messages/uniworx/de.msg | 8 ++++++-- routes | 5 ++++- src/Foundation.hs | 21 ++++++++++++++++++--- src/Handler/Course.hs | 16 +++++++++++++++- src/Handler/Exam.hs | 34 +++++++++++++++++++++++++++++++++- 5 files changed, 76 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8c713c0a0..492a08b54 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1104,7 +1104,7 @@ ExamOccurrences: Prüfungen ExamRoomAlreadyExists: Prüfung ist bereits eingetragen ExamRoom: Raum ExamRoomCapacity: Kapazität -ExamRoomCapacityNonPositive: Kapazität muss positiv und größer null sein +ExamRoomCapacityNegative: Kapazität darf nicht negativ sein ExamRoomTime: Termin ExamRoomStart: Beginn ExamRoomEnd: Ende @@ -1141,4 +1141,8 @@ ExamBonusPointsPassed possible@Points: Maximal #{showFixed True possible} Klausu ExamPassed: Bestanden ExamNotPassed: Nicht bestanden -ExamResult: Klausurergebnis \ No newline at end of file +ExamResult: Klausurergebnis + +ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet +ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet +ExamRegistered: Angemeldet \ No newline at end of file diff --git a/routes b/routes index 9d35caa33..a6241127d 100644 --- a/routes +++ b/routes @@ -143,7 +143,10 @@ /show EShowR GET !time /edit EEditR GET POST /corrector-invite ECInviteR GET POST - + /users EUsersR GET POST !timeANDcorrector + /users/new EAddUserR GET POST + /users/invite EInviteR GET POST + /register ERegisterR POST !timeANDcourse-registered !timeANDexam-registered /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Foundation.hs b/src/Foundation.hs index 821427118..97dd384f5 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -650,12 +650,27 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor) return Authorized tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of - CExamR tid ssh csh examn _subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do + CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh - Entity _ Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn + Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn cTime <- liftIO getCurrentTime + registered <- case mAuthId of + Just uid -> $cachedHereBinary (eId, uid) . lift . existsBy $ UniqueExamRegistration eId uid + Nothing -> return False - guard $ NTop examVisibleFrom <= NTop (Just cTime) + let visible = NTop examVisibleFrom <= NTop (Just cTime) + + case subRoute of + EShowR -> guard visible + EUsersR -> guard $ examStart <= cTime + && NTop (Just cTime) <= NTop examFinished + ERegisterR + | not registered -> guard $ visible + && NTop examRegisterFrom <= NTop (Just cTime) + && NTop (Just cTime) <= NTop examRegisterTo + | otherwise -> guard $ visible + && NTop (Just cTime) <= NTop examDeregisterUntil + _ -> return () return Authorized diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f849fb282..f55328ca5 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -430,7 +430,21 @@ getCShowR tid ssh csh = do $maybe endT' <- endT \ – #{endT'} |] - + , 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 [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 ] dbtSorting = Map.fromList [ ("name", SortColumn $ \exam -> exam E.^. ExamName ) diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index dffde8e32..f44a78abf 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -275,7 +275,7 @@ examOccurrenceForm prev = wFormToAForm $ do examOccurrenceForm' nudge mPrev csrf = do (eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev) (eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "name")) (eofRoom <$> mPrev) - (eofCapacityRes, eofCapacityView) <- mpreq (posIntFieldI MsgExamRoomCapacityNonPositive) ("" & addName (nudge "capacity")) (eofCapacity <$> 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) (eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev) @@ -691,3 +691,35 @@ getEShowR tid ssh csh examn = do examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") $(widgetFile "exam-show") + +getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEUsersR = postEUsersR +postEUsersR = error "postEUsersR" + +getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEAddUserR = postEAddUserR +postEAddUserR = error "postEAddUserR" + +getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +getEInviteR = postEInviteR +postEInviteR = error "postEInviteR" + +postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +postERegisterR tid ssh csh examn = do + uid <- requireAuthId + + Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn + + ((btnResult, _), _) <- runFormPost buttonForm + + formResult btnResult $ \case + BtnRegister -> do + runDB . void . insert $ ExamRegistration eId uid Nothing + addMessageI Success $ MsgExamRegisteredSuccess examn + redirect $ CExamR tid ssh csh examn EShowR + BtnDeregister -> do + runDB . deleteBy $ UniqueExamRegistration eId uid + addMessageI Success $ MsgExamDeregisteredSuccess examn + redirect $ CExamR tid ssh csh examn EShowR + + invalidArgs ["Register/Deregister button required"] From 1684da07f2352f76df7cef3bd7b33aa32a8dda97 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Jun 2019 17:33:55 +0200 Subject: [PATCH 07/17] fix(exams): Fix registration --- messages/uniworx/de.msg | 5 ++++- src/Foundation.hs | 27 +++++++++++++++++++++++++++ src/Handler/Exam.hs | 25 +++++++++++++++++++++++-- src/Model/Types/Security.hs | 1 + templates/exam-show.hamlet | 4 ++++ 5 files changed, 59 insertions(+), 3 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 492a08b54..ef3910846 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -878,6 +878,7 @@ AuthTagTutor: Nutzer ist Tutor AuthTagTime: Zeitliche Einschränkungen sind erfüllt AuthTagCourseRegistered: Nutzer ist Kursteilnehmer AuthTagTutorialRegistered: Nutzer ist Tutoriumsteilnehmer +AuthTagExamRegistered: Nutzer ist Klausurteilnehmer AuthTagParticipant: Nutzer ist mit Kurs assoziiert AuthTagRegisterGroup: Nutzer ist nicht Mitglied eines anderen Tutoriums mit der selben Registrierungs-Gruppe AuthTagCapacity: Kapazität ist ausreichend @@ -1145,4 +1146,6 @@ ExamResult: Klausurergebnis ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet -ExamRegistered: Angemeldet \ No newline at end of file +ExamRegistered: Angemeldet +ExamNotRegistered: Nicht angemeldet +ExamRegistration: Anmeldung \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 97dd384f5..21349c919 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -797,6 +797,33 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthTutorialRegistered r +tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of + CExamR tid ssh csh examn _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. exam E.^. ExamName E.==. E.val examn + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + CourseR tid ssh csh _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId + [E.Value c] <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do + E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam + E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse + E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) + return Authorized + r -> $unsupportedAuthPredicate AuthExamRegistered r tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index f44a78abf..5a7817339 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -634,7 +634,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) <- runDB $ do + (Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister)) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -671,9 +671,30 @@ getEShowR tid ssh csh examn = do let occurrences = map (over _2 E.unValue) occurrencesRaw - return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences) + 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)) let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences + registerWidget + | Just isRegistered <- registered + , mayRegister = Just $ do + (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered + [whamlet| +

+ $if isRegistered + _{MsgExamRegistered} + $else + _{MsgExamNotRegistered} + |] + wrapForm examRegisterForm def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR + , formEncoding = examRegisterEnctype + , formSubmit = FormNoSubmit + } + | fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|] + | otherwise = Nothing let heading = prependCourseTitle tid ssh csh $ CI.original examName diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 1c1919fdf..805e7d96d 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -42,6 +42,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä | AuthTutor | AuthCourseRegistered | AuthTutorialRegistered + | AuthExamRegistered | AuthParticipant | AuthTime | AuthMaterials diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 36625be20..3603fee38 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -81,6 +81,10 @@ $maybe desc <- examDescription \ ^{isVisible False}

$# TODO + $maybe registerWdgt <- registerWidget +
_{MsgExamRegistration} +
^{registerWdgt} + $if not (null occurrences)
From f8d0b021edcf254c161ff98e1183e9e4bfab0df9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 26 Jun 2019 19:34:56 +0200 Subject: [PATCH 08/17] feat(forms): Introduce more convenient form validation --- ChangeLog.md | 4 +++ messages/uniworx/de.msg | 4 ++- src/Handler/Exam.hs | 16 ++++++++++-- src/Utils/Form.hs | 56 ++++++++++++++++++++++++++++++++++++++++- 4 files changed, 76 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 25616306d..2cfe46396 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 26.06.2019 + + Rudimentäre Unterstützung für Klausurbetrieb + * Version 07.06.2019 Abgaben können bestimmte Dateinamen und Endungen erzwingen diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ef3910846..66a159c18 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1148,4 +1148,6 @@ ExamRegisteredSuccess exam@ExamName: Erfolgreich zur Klausur #{exam} angemeldet ExamDeregisteredSuccess exam@ExamName: Erfolgreich von der Klausur #{exam} abgemeldet ExamRegistered: Angemeldet ExamNotRegistered: Nicht angemeldet -ExamRegistration: Anmeldung \ No newline at end of file +ExamRegistration: Anmeldung + +ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen \ No newline at end of file diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 5a7817339..d63ed3de9 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -25,6 +25,8 @@ import Text.Blaze.Html.Renderer.String (renderHtml) import qualified Data.CaseInsensitive as CI +import qualified Control.Monad.State.Class as State + getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamListR tid ssh csh = do @@ -438,6 +440,16 @@ examTemplate cid = runMaybeT $ do , efCorrectors = Set.empty } + +validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m () +validateExam = do + ExamForm{..} <- State.get + + guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart) + + -- TODO + + getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCExamNewR = postCExamNewR postCExamNewR tid ssh csh = do @@ -446,7 +458,7 @@ postCExamNewR tid ssh csh = do template <- examTemplate cid return (cid, template) - ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost $ examForm template + ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template formResult newExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do @@ -525,7 +537,7 @@ postEEditR tid ssh csh examn = do return (cid, eId, template) - ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . examForm $ Just template + ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template formResult editExamResult $ \ExamForm{..} -> do insertRes <- runDBJobs $ do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 3947e214d..86d757dec 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Utils.Form where @@ -23,8 +24,11 @@ import qualified Data.Set as Set import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Trans.RWS (mapRWST) +import Control.Monad.State.Class (MonadState(..)) +import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST) import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Morph (MFunctor(..)) import Data.List ((!!)) @@ -779,6 +783,56 @@ prismAForm p outer form = review p <$> form inner where inner = outer >>= preview p +newtype FormValidator r m a = FormValidator { unFormValidator :: RWST () [SomeMessage (HandlerSite m)] r m a } + +deriving newtype instance Functor m => Functor (FormValidator r m) +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) +instance MonadTrans (FormValidator r) where + lift = FormValidator . lift + +validateForm :: MonadHandler m + => FormValidator a m () + -> (Markup -> MForm m (FormResult a, xml)) + -> (Markup -> MForm m (FormResult a, xml)) +validateForm valF form csrf = do + (res, xml) <- form csrf + res' <- for res $ lift . execRWST (unFormValidator valF) () + (, xml) <$> case res' of + FormSuccess (x, [] ) -> return $ FormSuccess x + FormSuccess (_, msgs) -> formFailure msgs + FormMissing -> return FormMissing + FormFailure errs -> return $ FormFailure errs + +validateFormDB :: ( MonadHandler m + , YesodPersist (HandlerSite m) + ) + => FormValidator a (YesodDB (HandlerSite m)) () + -> (Markup -> MForm m (FormResult a, xml)) + -> (Markup -> MForm m (FormResult a, xml)) +validateFormDB (FormValidator valF) = validateForm . FormValidator $ hoist (liftHandlerT . runDB) valF + +tellValidationError :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + ) + => msg -> FormValidator r m () +tellValidationError = FormValidator . tell . pure . SomeMessage + +guardValidation :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + ) + => msg -> Bool -> FormValidator r m () +guardValidation _ False = return () +guardValidation msg True = tellValidationError msg + +guardValidationM :: ( MonadHandler m + , RenderMessage (HandlerSite m) msg + ) + => msg -> m Bool -> FormValidator r m () +guardValidationM = (. lift) . (=<<) . guardValidation + ----------------------- -- Form Manipulation -- ----------------------- From 52c4a689385ed97195817b2648144d7a55f4c010 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 26 Jun 2019 21:28:31 +0200 Subject: [PATCH 09/17] Lecturer info exams added --- src/Utils.hs | 26 +++++++-- templates/i18n/info-lecturer/de.hamlet | 78 ++++++++++++++++++++++++-- 2 files changed, 95 insertions(+), 9 deletions(-) diff --git a/src/Utils.hs b/src/Utils.hs index 4f565befe..e34abcd21 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -136,9 +136,25 @@ fontAwesomeIcon iconName = iconQuestion :: Markup iconQuestion = fontAwesomeIcon "question-circle" +iconNew :: Markup +iconNew = fontAwesomeIcon "seedling" + +iconOK :: Markup +iconOK = fontAwesomeIcon "check" + +iconNotOK :: Markup +iconNotOK = fontAwesomeIcon "times" + +iconWarning :: Markup +iconWarning = fontAwesomeIcon "exclamation" + +iconProblem :: Markup +iconProblem = fontAwesomeIcon "bolt" + iconHint :: Markup iconHint = fontAwesomeIcon "life-ring" +-- Icons for SheetFileType iconSolution :: Markup iconSolution =fontAwesomeIcon "exclamation-circle" @@ -177,21 +193,21 @@ hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not a hasTickmark :: Bool -> Markup -- ^ Display an icon that denotes that something™ is okay -hasTickmark True = fontAwesomeIcon "check" +hasTickmark True = iconOK hasTickmark False = mempty isBad :: Bool -> Markup -- ^ Display an icon that denotes that something™ is bad -isBad True = fontAwesomeIcon "bolt" -- or times?! +isBad True = iconProblem isBad False = mempty isNew :: Bool -> Markup -isNew True = fontAwesomeIcon "seedling" -- was exclamation +isNew True = iconNew isNew False = mempty boolSymbol :: Bool -> Markup -boolSymbol True = fontAwesomeIcon "check" -boolSymbol False = fontAwesomeIcon "times" +boolSymbol True = iconOK +boolSymbol False = iconNotOK diff --git a/templates/i18n/info-lecturer/de.hamlet b/templates/i18n/info-lecturer/de.hamlet index e766ef7da..0d34ff8b0 100644 --- a/templates/i18n/info-lecturer/de.hamlet +++ b/templates/i18n/info-lecturer/de.hamlet @@ -7,8 +7,16 @@ $newline text

Bekannte Probleme in Bearbeitung
-
Derzeit keine bekannt. +
Klausuren #{iconNew} +
+ Klausuren werden ab sofort teilweise unterstüzt. + Der genaue Stand der Entwicklung ist weiter unter auf dieser + Seite in einem eigenem Abschnitt detailliert. +
Benachrichtigungen +
+ Benachrichtigungen werden momentan oft mit großer Verzögerung versandt. + Die Ursache ist derzeit noch unbekannt, da das Problem noch nicht genauer untersucht werden konnte. $# $# MOVE ITEM TO SECTION "VERANSTALTUNGEN", once it is implemented: @@ -241,10 +249,72 @@ $newline text
-

Klausuren - Das Verwalten von Klausuren und Notenmeldungen - ist leider noch nicht fertig implementiert. +

Klausuren +

Das Verwalten von Klausuren und Notenmeldungen wurde nun teilweise implementiert und ist ab sofort einsetzbar. +

+
Anlegen/Editieren +
+ Klausuren können von Dozenten und Assistenten angelegt werden. + Eine Vielzahl von optionalen Eigenschaften können sofort oder später angegeben werden, + z.B. Sichtbarkeit und Anmeldezeitraum. +
Prüfungen +
+ Eine Klausur kann in mehrere Prüfungen unterteilt sein, welche jeweils einen eigenen Ort und Zeitraum besitzen. +

+ Im einfachsten Fall lassen sich damit Klausuren abbilden, welche gleichzeitig in verschiedenen Räumen stattfinden. + Es lassen sich damit jetzt aber auch zeitlich getrennte Prüfungen verwalten, wie z.B. mündliche Prüfungen bei Seminaren oder Praktika. + Teilnehmern wird eine übersichtliche Tabelle aller Prüfungen angezeigt. + +

#{iconProblem} Prüfungszuteilung +
+ Auf Wunsch kann Uni2work die Zuteilung der Teilnehmer auf die Prüfungen (Räume bzw. Prüfungstermine) + nach verschiedenen Kriterien wie Name oder Matrikelnummer vornehmen. + +
#{iconWarning} Anmeldungen +
+ Teilnehmer können sich bereits zu sichtbaren Klausur innerhalb des eingestellten + Anmeldezeitraums anmelden. +

+ + Achtung: # + Die Liste der angemeldeten Teilnehmer ist momentan noch nicht einsehbar oder exportierbar, wird aber sicher gespeichert. + Dieses Feature folgt in Kürze. + +

#{iconProblem} Korrekturen +
+

+ Korrekturen können derzeit noch nicht eingetragen werden. # + Die Realisierung sollte in wenigen Wochen erfolgen. +

+ Es besteht auch die Option, Namen für Teilaufgaben und/oder Klausurkorrektoren einzutragen. + $# Besondere Rechte für Klausurkorrektoren? + +

#{iconProblem} Klausurbonus +
+ Es werden verschiedene Möglichkeiten angebotenen werden, + die erzielten Bewertungen der Hausübungen + unter einstellbaren Bedingungen + in einen Klausurbonus umzurechnen (z.B. anrechnung nur, falls bereits ohne Bonus bestanden). + +
#{iconProblem} Notenmeldung +
+

+ Endnoten können leider noch nicht ans Prüfungsamt gemeldet werden. +

+ Im Unterschied zum alten UniWorX gibt es keinen Knopf mehr zu Notenmeldung. + Stattdessen kann ein Datum eingetragen werden, ab dem die Klausur an das Prüfungsamt übergeben wird. + Dadurch kann die Notenmeldung nicht mehr vergessen werden. +

+ Damit nachträgliche Änderungen nicht mehr verloren gehen können, + dürfen Dozenten nach dem Übergabedatum an das Prüfungsamt + keine Änderungen mehr an der Klausur vornehmen, da diese dann + ein Teil der Unterlagen des Prüfungsamtes ist. +

+ Dozenten können jedoch explizit kleinere nachträgliche Änderungen an das + Prüfungsamt übermitteln. Für größere Änderungen kann das Prüfungsamt + die Klausur auch wieder an den Dozenten zurück übergeben; + der Dozent trägt dann einfach ein späteres Datum für die Übergabe ein.

Sonstiges
From 96387cbed5bda9b901706318e1931e6e718a0680 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Jun 2019 08:55:32 +0200 Subject: [PATCH 10/17] fix(many occurrences throughout the project): Fix typo: occurence -> occurrence everywhere A typo between occurence in code and occurrence in tests prevented deployment. I changed all occurrences of "occurence" to the correct spelling, such that --- messages/uniworx/de.msg | 4 +- models/tutorials | 2 +- src/Handler/Admin.hs | 2 +- src/Handler/Course.hs | 2 +- src/Handler/Tutorial.hs | 8 +- .../Form/{Occurences.hs => Occurrences.hs} | 78 +++++++++---------- src/Handler/Utils/Table/Cells.hs | 18 ++--- src/Model/Types/DateTime.hs | 20 ++--- src/Utils/Lens.hs | 12 +-- src/Utils/{Occurences.hs => Occurrences.hs} | 30 +++---- .../{occurence => occurrence}/cell.hamlet | 6 +- .../cell/except-no-occur.hamlet | 0 .../cell/except-occur.hamlet | 0 .../cell/weekly.hamlet | 0 .../form/except-add.hamlet | 0 .../form/except-layout.hamlet | 0 .../form/except-no-occur.hamlet | 0 .../form/except-occur.hamlet | 0 .../form/scheduled-add.hamlet | 0 .../form/scheduled-layout.hamlet | 0 .../form/weekly.hamlet | 0 test/Database.hs | 12 +-- test/Model/TypesSpec.hs | 18 ++--- 23 files changed, 106 insertions(+), 106 deletions(-) rename src/Handler/Utils/Form/{Occurences.hs => Occurrences.hs} (63%) rename src/Utils/{Occurences.hs => Occurrences.hs} (73%) rename templates/widgets/{occurence => occurrence}/cell.hamlet (64%) rename templates/widgets/{occurence => occurrence}/cell/except-no-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/cell/except-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/cell/weekly.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-add.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-layout.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-no-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/except-occur.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/scheduled-add.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/scheduled-layout.hamlet (100%) rename templates/widgets/{occurence => occurrence}/form/weekly.hamlet (100%) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2195c86a5..bf7943f8b 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -965,8 +965,8 @@ ScheduleRegular: Planmäßiger Termin ScheduleRegularKind: Plan WeekDay: Wochentag Day: Tag -OccurenceStart: Beginn -OccurenceEnd: Ende +OccurrenceStart: Beginn +OccurrenceEnd: Ende ScheduleExists: Dieser Plan existiert bereits ScheduleExceptions: Termin-Ausnahmen diff --git a/models/tutorials b/models/tutorials index 4961e0bd5..166a8dbef 100644 --- a/models/tutorials +++ b/models/tutorials @@ -4,7 +4,7 @@ Tutorial json type (CI Text) -- "Tutorium", "Zentralübung", ... capacity Int Maybe -- limit for enrolment in this tutorial room Text - time Occurences + time Occurrences regGroup (CI Text) Maybe -- each participant may register for one tutorial per regGroup registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 6f13dba0c..1b6242611 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -165,7 +165,7 @@ postAdminTestR = do -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell) -- - -- This /needs/ to replace all occurences of @mreq@ with @mpreq@ (no fields should be /actually/ required) + -- This /needs/ to replace all occurrences of @mreq@ with @mpreq@ (no fields should be /actually/ required) mkAddForm :: ListPosition -- ^ Approximate position of the add-widget -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3 -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 5abd1e624..c31b7048c 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -360,7 +360,7 @@ getCShowR tid ssh csh = do ^{nameEmailWidget' tutor} |] , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo , sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index caeeb11c1..fe0820abf 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -8,7 +8,7 @@ import Handler.Utils.Tutorial import Handler.Utils.Table.Cells import Handler.Utils.Delete import Handler.Utils.Communication -import Handler.Utils.Form.Occurences +import Handler.Utils.Form.Occurrences import Handler.Utils.Invitations import Jobs.Queue @@ -64,7 +64,7 @@ getCTutorialListR tid ssh csh = do , sortable (Just "participants") (i18nCell MsgTutorialParticipants) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, n) } -> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) . toWidget $ tshow n , sortable (Just "capacity") (i18nCell MsgTutorialCapacity) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . tshow) tutorialCapacity , sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> textCell tutorialRoom - , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurencesCell tutorialTime + , sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> occurrencesCell tutorialTime , sortable (Just "register-group") (i18nCell MsgTutorialRegGroup) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybe mempty (textCell . CI.original) tutorialRegGroup , sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterFrom , sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = (Entity _ Tutorial{..}, _) } -> maybeDateTimeCell tutorialRegisterTo @@ -275,7 +275,7 @@ data TutorialForm = TutorialForm , tfType :: CI Text , tfCapacity :: Maybe Int , tfRoom :: Text - , tfTime :: Occurences + , tfTime :: Occurrences , tfRegGroup :: Maybe (CI Text) , tfRegisterFrom :: Maybe UTCTime , tfRegisterTo :: Maybe UTCTime @@ -322,7 +322,7 @@ tutorialForm cid template html = do <*> areq (ciField & addDatalist tutTypeDatalist) (fslpI MsgTutorialType $ mr MsgTutorialType) (tfType <$> template) <*> aopt (natFieldI MsgTutorialCapacityNonPositive) (fslpI MsgTutorialCapacity (mr MsgTutorialCapacity) & setTooltip MsgTutorialCapacityTip) (tfCapacity <$> template) <*> areq textField (fslpI MsgTutorialRoom $ mr MsgTutorialRoomPlaceholder) (tfRoom <$> template) - <*> occurencesAForm ("occurences" :: Text) (tfTime <$> template) + <*> occurrencesAForm ("occurrences" :: Text) (tfTime <$> template) <*> fmap (assertM (not . Text.null . CI.original) . fmap (CI.map Text.strip)) (aopt ciField (fslI MsgTutorialRegGroup & setTooltip MsgTutorialRegGroupTip) ((tfRegGroup <$> template) <|> Just (Just "tutorial"))) <*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate) & setTooltip MsgCourseRegisterFromTip diff --git a/src/Handler/Utils/Form/Occurences.hs b/src/Handler/Utils/Form/Occurrences.hs similarity index 63% rename from src/Handler/Utils/Form/Occurences.hs rename to src/Handler/Utils/Form/Occurrences.hs index da0e7733f..e3de0c461 100644 --- a/src/Handler/Utils/Form/Occurences.hs +++ b/src/Handler/Utils/Form/Occurrences.hs @@ -1,5 +1,5 @@ -module Handler.Utils.Form.Occurences - ( occurencesAForm +module Handler.Utils.Form.Occurrences + ( occurrencesAForm ) where import Import @@ -12,33 +12,33 @@ import qualified Data.Map as Map import Utils.Lens - -data OccurenceScheduleKind = ScheduleKindWeekly + +data OccurrenceScheduleKind = ScheduleKindWeekly deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceScheduleKind -instance Finite OccurenceScheduleKind +instance Universe OccurrenceScheduleKind +instance Finite OccurrenceScheduleKind -nullaryPathPiece ''OccurenceScheduleKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceScheduleKind id +nullaryPathPiece ''OccurrenceScheduleKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceScheduleKind id -data OccurenceExceptionKind = ExceptionKindOccur +data OccurrenceExceptionKind = ExceptionKindOccur | ExceptionKindNoOccur deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) -instance Universe OccurenceExceptionKind -instance Finite OccurenceExceptionKind +instance Universe OccurrenceExceptionKind +instance Finite OccurrenceExceptionKind -nullaryPathPiece ''OccurenceExceptionKind $ camelToPathPiece' 2 -embedRenderMessage ''UniWorX ''OccurenceExceptionKind id +nullaryPathPiece ''OccurrenceExceptionKind $ camelToPathPiece' 2 +embedRenderMessage ''UniWorX ''OccurrenceExceptionKind id -occurencesAForm :: PathPiece ident => ident -> Maybe Occurences -> AForm Handler Occurences -occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do +occurrencesAForm :: PathPiece ident => ident -> Maybe Occurrences -> AForm Handler Occurrences +occurrencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do Just cRoute <- getCurrentRoute - + let - scheduled :: AForm Handler (Set OccurenceSchedule) + scheduled :: AForm Handler (Set OccurrenceSchedule) scheduled = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -47,16 +47,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__scheduled" :: Text) (fslI MsgScheduleRegular & setTooltip MsgMassInputTip) False - (Set.toList . occurencesScheduled <$> mPrev) + (Set.toList . occurrencesScheduled <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceSchedule] -> FormResult [OccurenceSchedule]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceSchedule] -> FormResult [OccurrenceSchedule]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/scheduled-add")) . renderAForm FormStandard . wFormToAForm $ do newSched <- multiActionW (Map.fromList [ ( ScheduleKindWeekly , ScheduleWeekly <$> apreq (selectField optionsFinite) (fslI MsgWeekDay & addName (nudge "occur-week-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) ] ) (fslI MsgScheduleRegularKind & addName (nudge "kind")) Nothing @@ -65,16 +65,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do | newSched' `elem` oldScheds -> FormFailure [mr MsgScheduleExists] | otherwise -> FormSuccess $ pure newSched' - miCell' :: OccurenceSchedule -> Widget + miCell' :: OccurrenceSchedule -> Widget miCell' ScheduleWeekly{..} = do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/form/weekly") + $(widgetFile "widgets/occurrence/form/weekly") - miLayout' :: MassInputLayout ListLength OccurenceSchedule () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/scheduled-layout") + miLayout' :: MassInputLayout ListLength OccurrenceSchedule () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/scheduled-layout") - exceptions :: AForm Handler (Set OccurenceException) + exceptions :: AForm Handler (Set OccurrenceException) exceptions = Set.fromList <$> massInputAccumA miAdd' miCell' @@ -83,16 +83,16 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do (miIdent' <> "__exceptions" :: Text) (fslI MsgScheduleExceptions & setTooltip (UniWorXMessages [SomeMessage MsgScheduleExceptionsTip, SomeMessage MsgMassInputTip])) False - (Set.toList . occurencesExceptions <$> mPrev) + (Set.toList . occurrencesExceptions <$> mPrev) where - miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurenceException] -> FormResult [OccurenceException]) - miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([OccurrenceException] -> FormResult [OccurrenceException]) + miAdd' nudge submitView = over (mapped . mapped . _2) (\addWidget -> $(widgetFile "widgets/occurrence/form/except-add")) . renderAForm FormStandard . wFormToAForm $ do newExc <- multiActionW (Map.fromList [ ( ExceptionKindOccur , ExceptOccur <$> apreq dayField (fslI MsgDay & addName (nudge "occur-day")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceStart & addName (nudge "occur-start")) Nothing - <*> apreq timeFieldTypeTime (fslI MsgOccurenceEnd & addName (nudge "occur-end")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceStart & addName (nudge "occur-start")) Nothing + <*> apreq timeFieldTypeTime (fslI MsgOccurrenceEnd & addName (nudge "occur-end")) Nothing ) , ( ExceptionKindNoOccur , ExceptNoOccur @@ -104,20 +104,20 @@ occurencesAForm (toPathPiece -> miIdent') mPrev = wFormToAForm $ do return $ newExc <&> \newExc' oldExcs -> if | newExc' `elem` oldExcs -> FormFailure [mr MsgExceptionExists] | otherwise -> FormSuccess $ pure newExc' - - miCell' :: OccurenceException -> Widget + + miCell' :: OccurrenceException -> Widget miCell' ExceptOccur{..} = do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptEnd - $(widgetFile "widgets/occurence/form/except-occur") + $(widgetFile "widgets/occurrence/form/except-occur") miCell' ExceptNoOccur{..} = do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/form/except-no-occur") + $(widgetFile "widgets/occurrence/form/except-no-occur") - miLayout' :: MassInputLayout ListLength OccurenceException () - miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurence/form/except-layout") + miLayout' :: MassInputLayout ListLength OccurrenceException () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/occurrence/form/except-layout") - aFormToWForm $ Occurences + aFormToWForm $ Occurrences <$> scheduled <*> exceptions diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 620e6776b..b901fb8d3 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -14,7 +14,7 @@ import Text.Blaze (ToMarkup(..)) import Utils.Lens import Handler.Utils -import Utils.Occurences +import Utils.Occurrences import qualified Data.Set as Set @@ -248,19 +248,19 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc -occurencesCell :: IsDBTable m a => Occurences -> DBCell m a -occurencesCell (normalizeOccurences -> Occurences{..}) = cell $ do - let occurencesScheduled' = flip map (Set.toList occurencesScheduled) $ \case +occurrencesCell :: IsDBTable m a => Occurrences -> DBCell m a +occurrencesCell (normalizeOccurrences -> Occurrences{..}) = cell $ do + let occurrencesScheduled' = flip map (Set.toList occurrencesScheduled) $ \case ScheduleWeekly{..} -> do scheduleStart' <- formatTime SelFormatTime scheduleStart scheduleEnd' <- formatTime SelFormatTime scheduleEnd - $(widgetFile "widgets/occurence/cell/weekly") - occurencesExceptions' = flip map (Set.toList occurencesExceptions) $ \case + $(widgetFile "widgets/occurrence/cell/weekly") + occurrencesExceptions' = flip map (Set.toList occurrencesExceptions) $ \case ExceptOccur{..} -> do exceptStart' <- formatTime SelFormatDateTime (LocalTime exceptDay exceptStart) exceptEnd' <- formatTime SelFormatTime exceptStart - $(widgetFile "widgets/occurence/cell/except-occur") + $(widgetFile "widgets/occurrence/cell/except-occur") ExceptNoOccur{..} -> do exceptTime' <- formatTime SelFormatDateTime exceptTime - $(widgetFile "widgets/occurence/cell/except-no-occur") - $(widgetFile "widgets/occurence/cell") + $(widgetFile "widgets/occurrence/cell/except-no-occur") + $(widgetFile "widgets/occurrence/cell") diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 10783550e..c72a6ba37 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -2,7 +2,7 @@ Module: Model.Types.DateTime Description: Time related types -Terms, Seasons, and Occurence schedules +Terms, Seasons, and Occurrence schedules -} module Model.Types.DateTime ( module Model.Types.DateTime @@ -152,7 +152,7 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 termYear = year term -data OccurenceSchedule = ScheduleWeekly +data OccurrenceSchedule = ScheduleWeekly { scheduleDayOfWeek :: WeekDay , scheduleStart :: TimeOfDay , scheduleEnd :: TimeOfDay @@ -164,9 +164,9 @@ deriveJSON defaultOptions , constructorTagModifier = camelToPathPiece' 1 , tagSingleConstructors = True , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule + } ''OccurrenceSchedule -data OccurenceException = ExceptOccur +data OccurrenceException = ExceptOccur { exceptDay :: Day , exceptStart :: TimeOfDay , exceptEnd :: TimeOfDay @@ -180,15 +180,15 @@ deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException + } ''OccurrenceException -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException +data Occurrences = Occurrences + { occurrencesScheduled :: Set OccurrenceSchedule + , occurrencesExceptions :: Set OccurrenceException } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences + } ''Occurrences +derivePersistFieldJSON ''Occurrences diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index b4cd5a572..7ebf61d99 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -111,15 +111,15 @@ makeLenses_ ''SubmissionMode makePrisms ''E.Value -makeLenses_ ''OccurenceSchedule +makeLenses_ ''OccurrenceSchedule -makePrisms ''OccurenceSchedule +makePrisms ''OccurrenceSchedule -makeLenses_ ''OccurenceException +makeLenses_ ''OccurrenceException -makePrisms ''OccurenceException +makePrisms ''OccurrenceException -makeLenses_ ''Occurences +makeLenses_ ''Occurrences makeLenses_ ''PredDNF @@ -132,6 +132,6 @@ makeLenses_ ''PredDNF class HasInstanceID s a | s -> a where instanceID :: Lens' s a - + class HasJSONWebKeySet s a | s -> a where jsonWebKeySet :: Lens' s a diff --git a/src/Utils/Occurences.hs b/src/Utils/Occurrences.hs similarity index 73% rename from src/Utils/Occurences.hs rename to src/Utils/Occurrences.hs index 077d79250..a5e271136 100644 --- a/src/Utils/Occurences.hs +++ b/src/Utils/Occurrences.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -module Utils.Occurences - ( normalizeOccurences +module Utils.Occurrences + ( normalizeOccurrences ) where import ClassyPrelude @@ -20,21 +20,21 @@ import Data.Time import Data.Time.Calendar.WeekDate -normalizeOccurences :: Occurences -> Occurences --- ^ +normalizeOccurrences :: Occurrences -> Occurrences +-- ^ -- -- - Removes unnecessary exceptions -- - Merges overlapping schedules -normalizeOccurences initial +normalizeOccurrences initial | Left new <- runReader (runExceptT go) initial - = normalizeOccurences new + = normalizeOccurrences new | otherwise = initial where - go :: ExceptT Occurences (Reader Occurences) () + go :: ExceptT Occurrences (Reader Occurrences) () -- Find some inconsistency and `throwE` a version without it go = do - scheduled <- view _occurencesScheduled + scheduled <- view _occurrencesScheduled forM_ scheduled $ \case a@ScheduleWeekly{} -> do let @@ -50,35 +50,35 @@ normalizeOccurences initial | otherwise = Nothing merge _ = Nothing - merges <- views _occurencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a + merges <- views _occurrencesScheduled $ mapMaybe (\b -> (,) <$> pure b <*> merge b) . Set.toList . Set.delete a case merges of [] -> return () - ((b, merged) : _) -> throwE =<< asks (over _occurencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) + ((b, merged) : _) -> throwE =<< asks (over _occurrencesScheduled $ Set.insert merged . Set.delete b . Set.delete a) - exceptions <- view _occurencesExceptions + exceptions <- view _occurrencesExceptions forM_ exceptions $ \case needle@ExceptNoOccur{..} -> do let LocalTime{..} = exceptTime (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate localDay - needed <- views _occurencesScheduled . any $ \case + needed <- views _occurrencesScheduled . any $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart <= localTimeOfDay , localTimeOfDay <= scheduleEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.delete needle) needle@ExceptOccur{..} -> do let (_, _, toEnum . (`mod` 7) -> localWeekDay) = toWeekDate exceptDay -- | Does this ExceptNoOccur target within needle? withinNeedle ExceptNoOccur{..} = LocalTime exceptDay exceptStart <= exceptTime && exceptTime <= LocalTime exceptDay exceptEnd withinNeedle _ = False - needed <- views _occurencesScheduled . none $ \case + needed <- views _occurrencesScheduled . none $ \case ScheduleWeekly{..} -> and [ scheduleDayOfWeek == localWeekDay , scheduleStart == exceptStart , scheduleEnd == exceptEnd ] unless needed $ - throwE =<< asks (over _occurencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) + throwE =<< asks (over _occurrencesExceptions $ Set.filter (not . withinNeedle) . Set.delete needle) diff --git a/templates/widgets/occurence/cell.hamlet b/templates/widgets/occurrence/cell.hamlet similarity index 64% rename from templates/widgets/occurence/cell.hamlet rename to templates/widgets/occurrence/cell.hamlet index bb1f1f3d7..295b3ae24 100644 --- a/templates/widgets/occurence/cell.hamlet +++ b/templates/widgets/occurrence/cell.hamlet @@ -1,12 +1,12 @@ $newline never
    - $forall sched <- occurencesScheduled' + $forall sched <- occurrencesScheduled'
  • ^{sched} -$if not (null occurencesExceptions) +$if not (null occurrencesExceptions) $#
    $#
    $#
      - $forall exc <- occurencesExceptions' + $forall exc <- occurrencesExceptions'
    • ^{exc} diff --git a/templates/widgets/occurence/cell/except-no-occur.hamlet b/templates/widgets/occurrence/cell/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-no-occur.hamlet rename to templates/widgets/occurrence/cell/except-no-occur.hamlet diff --git a/templates/widgets/occurence/cell/except-occur.hamlet b/templates/widgets/occurrence/cell/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/cell/except-occur.hamlet rename to templates/widgets/occurrence/cell/except-occur.hamlet diff --git a/templates/widgets/occurence/cell/weekly.hamlet b/templates/widgets/occurrence/cell/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/cell/weekly.hamlet rename to templates/widgets/occurrence/cell/weekly.hamlet diff --git a/templates/widgets/occurence/form/except-add.hamlet b/templates/widgets/occurrence/form/except-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-add.hamlet rename to templates/widgets/occurrence/form/except-add.hamlet diff --git a/templates/widgets/occurence/form/except-layout.hamlet b/templates/widgets/occurrence/form/except-layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-layout.hamlet rename to templates/widgets/occurrence/form/except-layout.hamlet diff --git a/templates/widgets/occurence/form/except-no-occur.hamlet b/templates/widgets/occurrence/form/except-no-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-no-occur.hamlet rename to templates/widgets/occurrence/form/except-no-occur.hamlet diff --git a/templates/widgets/occurence/form/except-occur.hamlet b/templates/widgets/occurrence/form/except-occur.hamlet similarity index 100% rename from templates/widgets/occurence/form/except-occur.hamlet rename to templates/widgets/occurrence/form/except-occur.hamlet diff --git a/templates/widgets/occurence/form/scheduled-add.hamlet b/templates/widgets/occurrence/form/scheduled-add.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-add.hamlet rename to templates/widgets/occurrence/form/scheduled-add.hamlet diff --git a/templates/widgets/occurence/form/scheduled-layout.hamlet b/templates/widgets/occurrence/form/scheduled-layout.hamlet similarity index 100% rename from templates/widgets/occurence/form/scheduled-layout.hamlet rename to templates/widgets/occurrence/form/scheduled-layout.hamlet diff --git a/templates/widgets/occurence/form/weekly.hamlet b/templates/widgets/occurrence/form/weekly.hamlet similarity index 100% rename from templates/widgets/occurence/form/weekly.hamlet rename to templates/widgets/occurrence/form/weekly.hamlet diff --git a/test/Database.hs b/test/Database.hs index ea044ac75..f59df7ec2 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -586,9 +586,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 08 15 00) (TimeOfDay 10 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now @@ -604,9 +604,9 @@ fillDb = do , tutorialType = "Tutorium" , tutorialCapacity = Just 30 , tutorialRoom = "Hilbert-Raum" - , tutorialTime = Occurences - { occurencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) - , occurencesExceptions = Set.empty + , tutorialTime = Occurrences + { occurrencesScheduled = Set.singleton $ ScheduleWeekly Tuesday (TimeOfDay 10 15 00) (TimeOfDay 12 00 00) + , occurrencesExceptions = Set.empty } , tutorialRegGroup = Just "tutorium" , tutorialRegisterFrom = Just now diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index 3805809db..84596eabf 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -26,7 +26,7 @@ import Time.Types (WeekDay(..)) instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where arbitrary = arbitrary `suchThatMap` fromNullable - + instance Arbitrary Season where arbitrary = genericArbitrary shrink = genericShrink @@ -71,7 +71,7 @@ instance Arbitrary SheetGradeSummary where instance Arbitrary SheetGroup where arbitrary = genericArbitrary shrink = genericShrink - + instance Arbitrary SheetTypeSummary where arbitrary = genericArbitrary shrink = genericShrink @@ -79,7 +79,7 @@ instance Arbitrary SheetTypeSummary where instance Arbitrary SheetFileType where arbitrary = genericArbitrary shrink = genericShrink - + instance Arbitrary SubmissionFileType where arbitrary = genericArbitrary shrink = genericShrink @@ -151,7 +151,7 @@ instance Arbitrary AuthTag where shrink = genericShrink instance CoArbitrary AuthTag where coarbitrary = genericCoarbitrary - + instance Arbitrary AuthTagActive where arbitrary = AuthTagActive <$> arbitrary shrink = genericShrink @@ -180,7 +180,7 @@ instance Arbitrary AuthenticationMode where authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2) return $ AuthPWHash{..} ] - + shrink AuthLDAP = [] shrink (AuthPWHash _) = [AuthLDAP] @@ -199,18 +199,18 @@ instance Arbitrary Html where instance Arbitrary WeekDay where arbitrary = oneof $ map pure [minBound..maxBound] -instance Arbitrary OccurenceSchedule where +instance Arbitrary OccurrenceSchedule where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary OccurenceException where +instance Arbitrary OccurrenceException where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary Occurences where +instance Arbitrary Occurrences where arbitrary = genericArbitrary shrink = genericShrink - + spec :: Spec spec = do From 6fb1399ef448eb1a6b92c652e644d6aaafe11673 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Jun 2019 10:58:35 +0200 Subject: [PATCH 11/17] feat(exams): Form validation --- messages/uniworx/de.msg | 11 ++++++++++- src/Handler/Exam.hs | 14 ++++++++++---- src/Utils/Form.hs | 7 ++++--- 3 files changed, 24 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1b460503d..386a3765f 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1066,6 +1066,7 @@ ExamRegisterFromTip: Zeitpunkt ab dem sich Kursteilnehmer selbständig zur Klaus 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 ExamFinished: Bewertung abgeschlossen ab ExamFinishedParticipant: Bewertung vorrausichtlich abgeschlossen @@ -1152,4 +1153,12 @@ ExamRegistered: Angemeldet ExamNotRegistered: Nicht angemeldet ExamRegistration: Anmeldung -ExamEndMustBeAfterStart: Beginn der Klausur muss vor ihrem Ende liegen \ No newline at end of file +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 +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 +ExamClosedMustBeAfterFinished: "Noten stehen fest ab" muss nach "Bewertung abgeschlossen ab" liegen +ExamClosedMustBeAfterStart: "Noten stehen fest ab" muss nach Start liegen +ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen \ No newline at end of file diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index d63ed3de9..51693fe85 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -203,7 +203,7 @@ examForm template html = do <*> 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)) (efPublishOccurrenceAssignments <$> template) + <*> areq utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignments) (efPublishOccurrenceAssignments <$> template) <*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template) <*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template) <* aformSection MsgExamFormOccurrences @@ -445,9 +445,15 @@ validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamF validateExam = do ExamForm{..} <- State.get - guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart) - - -- TODO + guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom + guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom + guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments $ efStart >= efPublishOccurrenceAssignments + guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop (Just efStart) + guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd + guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop (Just efStart) + guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished + guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop (Just efStart) + guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8a5da1d54..8ada2cc6d 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -828,9 +828,10 @@ tellValidationError = FormValidator . tell . pure . SomeMessage guardValidation :: ( MonadHandler m , RenderMessage (HandlerSite m) msg ) - => msg -> Bool -> FormValidator r m () -guardValidation _ False = return () -guardValidation msg True = tellValidationError msg + => msg -- ^ Message describing violation + -> Bool -- ^ @False@ iff constraint is violated + -> FormValidator r m () +guardValidation msg isValid = when (not isValid) $ tellValidationError msg guardValidationM :: ( MonadHandler m , RenderMessage (HandlerSite m) msg From 24aacef6af65d1c6c0cec53bd121abe1d889de2d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Jun 2019 11:09:44 +0200 Subject: [PATCH 12/17] fix(exam grading keys): Fix spacing --- src/Handler/Exam.hs | 2 +- templates/widgets/gradingKey.cassius | 3 +++ templates/widgets/gradingKey.hamlet | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) create mode 100644 templates/widgets/gradingKey.cassius diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 51693fe85..f8fb8722e 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -722,7 +722,7 @@ getEShowR tid ssh csh examn = do gradingKeyW :: [Points] -> Widget gradingKeyW bounds = let boundWidgets :: [Widget] - boundWidgets = map (toWidget . (pack :: String -> Text) . showFixed True) bounds + boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds grades :: [ExamGrade] grades = universeF in $(widgetFile "widgets/gradingKey") diff --git a/templates/widgets/gradingKey.cassius b/templates/widgets/gradingKey.cassius new file mode 100644 index 000000000..396f41818 --- /dev/null +++ b/templates/widgets/gradingKey.cassius @@ -0,0 +1,3 @@ +.table--grading-key + th, td + padding: 3px; \ No newline at end of file diff --git a/templates/widgets/gradingKey.hamlet b/templates/widgets/gradingKey.hamlet index e035911e1..dac9e9537 100644 --- a/templates/widgets/gradingKey.hamlet +++ b/templates/widgets/gradingKey.hamlet @@ -1,5 +1,5 @@ $newline never - +
      From e1e26abbbffd0f30a9e53c1a73f5bff7b1cb4afc Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 27 Jun 2019 11:22:04 +0200 Subject: [PATCH 13/17] fix(info-lecturer): Touch ups --- templates/i18n/info-lecturer/de.hamlet | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/templates/i18n/info-lecturer/de.hamlet b/templates/i18n/info-lecturer/de.hamlet index 0d34ff8b0..b01937d50 100644 --- a/templates/i18n/info-lecturer/de.hamlet +++ b/templates/i18n/info-lecturer/de.hamlet @@ -263,7 +263,8 @@ $newline text Eine Klausur kann in mehrere Prüfungen unterteilt sein, welche jeweils einen eigenen Ort und Zeitraum besitzen.

      Im einfachsten Fall lassen sich damit Klausuren abbilden, welche gleichzeitig in verschiedenen Räumen stattfinden. - Es lassen sich damit jetzt aber auch zeitlich getrennte Prüfungen verwalten, wie z.B. mündliche Prüfungen bei Seminaren oder Praktika. +

      + Es lassen sich aber auch zeitlich getrennte Prüfungen verwalten, wie z.B. mündliche Prüfungen bei Seminaren oder Praktika. Teilnehmern wird eine übersichtliche Tabelle aller Prüfungen angezeigt.

      #{iconProblem} Prüfungszuteilung @@ -284,11 +285,14 @@ $newline text
      #{iconProblem} Korrekturen

      - Korrekturen können derzeit noch nicht eingetragen werden. # - Die Realisierung sollte in wenigen Wochen erfolgen. + Korrekturen können derzeit noch nicht eingetragen werden. + Die Realisierung sollte in wenigen Wochen erfolgen.

      - Es besteht auch die Option, Namen für Teilaufgaben und/oder Klausurkorrektoren einzutragen. - $# Besondere Rechte für Klausurkorrektoren? + Die Eintragung von Korrekturen erfolgt immer pro Teilaufgabe. + Optional kann aus der erreichten Punktesumme dann automatisch eine Gesamtnote berechnet werden. +

      + Optional können Klausurkorrektoren angegeben werden, die ab Durchführung der Klausur berechtigt sind eigenständig Korrekturergebnisse einzutragen. + Es kann das Recht Ergebnisse einzutragen pro Korrektor auf bestimmte Teilaufgaben beschränkt werden.

      #{iconProblem} Klausurbonus
      From d07f53e1d8db10407d26d4fdd6e7c4c8a34b973d Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Jun 2019 16:51:38 +0200 Subject: [PATCH 14/17] fix(corrector assignment): sheet tabel mixed up columns sorted some columns did not belong to each other. --- src/Handler/Corrections.hs | 15 ++++++++++++--- src/Model.hs | 9 +++++++++ templates/corrections-overview.hamlet | 26 ++++++++++++++++++-------- 3 files changed, 39 insertions(+), 11 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 446b93273..ddf820d18 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1177,8 +1177,10 @@ assignHandler tid ssh csh cid assignSids = do let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps - sheetNames :: [SheetName] - sheetNames = Map.keys infoMap + + -- Always iterate over sheetList for consistent sorting! + sheetList :: [(SheetName, CorrectionInfo)] + sheetList = Map.toDescList sheetMap -- newest Sheet first, except for CorrectionSheetTable sheetMap :: Map SheetName CorrectionInfo sheetMap = Map.map fold infoMap @@ -1197,6 +1199,11 @@ assignHandler tid ssh csh cid assignSids = do corrMap :: Map (Maybe UserId) CorrectionInfo corrMap = Map.unionsWith (<>) $ Map.elems infoMap + corrInfos :: [CorrectionInfo] + corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap + where byName Nothing = Nothing + byName (Just uid) = Map.lookup uid correctorMap + corrMapSum :: CorrectionInfo corrMapSum = fold corrMap @@ -1235,7 +1242,9 @@ assignHandler tid ssh csh cid assignSids = do showAvgsDays Nothing _ = mempty showAvgsDays (Just dt) n = formatDiffDays $ dt / fromIntegral n heat :: Integer -> Integer -> Double - heat full achieved = roundToDigits 3 $ cutOffPercent 0.4 (fromIntegral full) (fromIntegral achieved) + heat = heat' 0.3 + heat' :: Double -> Integer -> Integer -> Double + heat' cut full achieved = roundToDigits 3 $ cutOffPercent cut (fromIntegral full^2) (fromIntegral achieved^2) let headingShort | 0 < Map.size assignment = MsgMenuCorrectionsAssignSheet $ Text.intercalate ", " $ fmap CI.original $ Map.keys assignment | otherwise = MsgMenuCorrectionsAssign diff --git a/src/Model.hs b/src/Model.hs index 45ce97e6d..ee5a8bbd8 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -37,5 +37,14 @@ deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial deriving instance Eq (Unique Exam) +instance Ord User where + compare User{userSurname=surnameA, userDisplayName=displayNameA, userEmail=emailA} + User{userSurname=surnameB, userDisplayName=displayNameB, userEmail=emailB} + = compare surnameA surnameB + <> compare displayNameA displayNameB + <> compare emailA emailB -- userEmail is unique, so this suffices + + + submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/templates/corrections-overview.hamlet b/templates/corrections-overview.hamlet index 94ada0543..61e75f123 100644 --- a/templates/corrections-overview.hamlet +++ b/templates/corrections-overview.hamlet @@ -1,5 +1,6 @@

      _{MsgCorrectionSheets} + _{MsgCourseParticipants nrParticipants} @@ -16,7 +17,8 @@
      _{MsgGenericMin} _{MsgGenericAvg} _{MsgGenericMax} - $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- Map.toList sheetMap + $# Always iterate over sheetList for consistent sorting! Newest first, except in this table + $forall (sheetName, CorrectionInfo{ciSubmittors, ciSubmissions, ciAssigned, ciCorrected, ciMin, ciTot, ciMax}) <- reverse sheetList
      ^{simpleLink (toWidget sheetName) (CSheetR tid ssh csh sheetName SSubsR)} $if groupsPossible @@ -39,15 +41,19 @@ #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} + +

      _{MsgCorrectionCorrectors} + @@ -56,13 +62,14 @@
      _{MsgCorrector} _{MsgGenericAll} _{MsgCorDeficitProportion} _{MsgCorrectionTime} - $forall shn <- sheetNames + $# Always iterate over sheetList for consistent sorting! Newest first, except in this table + $forall (shn,_) <- sheetList #{shn} $# ^{simpleLinkI (SomeMessage MsgMenuCorrectors) (CSheetR tid ssh csh shn SCorrR)}
      _{MsgGenericMin} _{MsgGenericAvg} _{MsgGenericMax} - $forall _shn <- sheetNames + $# Always iterate over sheetList for consistent sorting! Newest first, except in this table + $forall _shn <- sheetList _{MsgCorProportion} _{MsgNrSubmissionsTotalShort} _{MsgGenericNumChange} _{MsgNrSubmissionsNotCorrectedShort} _{MsgGenericAvg} - $forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, ciCorrected, ciMin, ciTot, ciMax}) <- Map.elems corrMap + $forall (CorrectionInfo{ciCorrector, ciSubmissions=ciSubmissionsNr, ciCorrected, ciMin, ciTot, ciMax}) <- corrInfos $with (nameW,loadM) <- getCorrector ciCorrector
      ^{nameW} @@ -77,7 +84,8 @@ #{showDiffDays ciMin} #{showAvgsDays ciTot ciCorrected} #{showDiffDays ciMax} - $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- Map.toList sheetMap + $# Always iterate over sheetList for consistent sorting! Newest first, except in this table + $forall (shn, CorrectionInfo{ciSubmissions=sheetSubmissionsNr}) <- sheetList $maybe SheetCorrector{sheetCorrectorLoad, sheetCorrectorState} <- Map.lookup shn loadM #{showCompactCorrectorLoad sheetCorrectorLoad sheetCorrectorState} @@ -101,7 +109,7 @@ - $if 0 < length sheetNames + $if not (null sheetList)
      Σ $with ciSubmissionsNr <- ciSubmissions corrMapSum @@ -112,9 +120,11 @@ #{showDiffDays (ciMin corrMapSum)} #{showAvgsDays (ciTot corrMapSum) (ciCorrected corrMapSum)} #{showDiffDays (ciMax corrMapSum)} - $forall shn <- sheetNames + $# Always iterate over sheetList for consistent sorting! Newest first, except in this table + $forall (shn, CorrectionInfo{ciSubmissions}) <- sheetList #{getLoadSum shn} - ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} + #{ciSubmissions} + ^{simpleLinkI (SomeMessage MsgMenuCorrectorsChange) (CSheetR tid ssh csh shn SCorrR)} ^{btnWdgt}

      _{MsgAssignSubmissionsRandomWarning} \ No newline at end of file From 16c556b852501a5e6c88094556f5054c4d4f352b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Jun 2019 18:48:15 +0200 Subject: [PATCH 15/17] fix(correction assignment): correcting lecturer's names are shown now Table only shows sheet correctors, but lecturers may occasionally correct too --- src/Handler/Corrections.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index ddf820d18..c3a2574fe 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1085,7 +1085,7 @@ assignHandler tid ssh csh cid assignSids = do (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions -- gather data - (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do + (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, lecturerNames) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] @@ -1141,6 +1141,12 @@ assignHandler tid ssh csh cid assignSids = do in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc ) + -- lecturerNames :: Map UserId User + lecturerNames <- fmap entities2map $ E.select $ E.from $ \(user `E.InnerJoin` lecturer) -> do + E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + return user + submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds let numSubmittors = E.sub_select . E.from $ \subUser -> do @@ -1173,7 +1179,7 @@ assignHandler tid ssh csh cid assignSids = do } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) + return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, lecturerNames) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps @@ -1203,7 +1209,6 @@ assignHandler tid ssh csh cid assignSids = do corrInfos = sortBy (compare `on` (byName . ciCorrector) ) $ Map.elems corrMap where byName Nothing = Nothing byName (Just uid) = Map.lookup uid correctorMap - corrMapSum :: CorrectionInfo corrMapSum = fold corrMap @@ -1213,6 +1218,8 @@ assignHandler tid ssh csh cid assignSids = do getCorrector (Just uid) | Just (User{..},loadMap) <- Map.lookup uid correctorMap = (nameEmailWidget userEmail userDisplayName userSurname, loadMap) + | Just (User{..} ) <- Map.lookup uid lecturerNames + = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty) -- avoid nestes hamlet $maybe with duplicated $nothing getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo From 8476314a46fa093231e6b0664a96e94284ff506f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 27 Jun 2019 19:53:26 +0200 Subject: [PATCH 16/17] Better fix for lecturer names --- src/Handler/Corrections.hs | 18 +++++++++--------- src/Handler/Utils/Corrections.hs | 2 ++ 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index c3a2574fe..851c1b1c4 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -1085,7 +1085,7 @@ assignHandler tid ssh csh cid assignSids = do (btnWdgt, btnResult) <- runButtonForm FIDAssignSubmissions -- gather data - (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, lecturerNames) <- runDB $ do + (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) <- runDB $ do -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh nrParticipants <- count [CourseParticipantCourse ==. cid] @@ -1141,11 +1141,11 @@ assignHandler tid ssh csh cid assignSids = do in Map.insertWith (\(usr, ma) (_, mb) -> (usr, Map.union ma mb)) uid (user, Map.singleton shn sheetcorr) acc ) - -- lecturerNames :: Map UserId User - lecturerNames <- fmap entities2map $ E.select $ E.from $ \(user `E.InnerJoin` lecturer) -> do - E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser - E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid - return user + -- -- lecturerNames :: Map UserId User + -- lecturerNames <- fmap entities2map $ E.select $ E.from $ \(user `E.InnerJoin` lecturer) -> do + -- E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser + -- E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid + -- return user submissions <- E.select . E.from $ \submission -> do E.where_ $ submission E.^. SubmissionSheet `E.in_` E.valList sheetIds @@ -1179,7 +1179,7 @@ assignHandler tid ssh csh cid assignSids = do } in Map.insertWith (Map.unionWith (<>)) shnm cinf m - return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment, lecturerNames) + return (assignSheetNames, nrParticipants, groupsPossible, infoMap, correctorMap, assignment) let -- infoMap :: Map SheetName (Map (Maybe UserId) CorrectionInfo) -- repeated here for easier reference -- create aggregate maps @@ -1218,8 +1218,8 @@ assignHandler tid ssh csh cid assignSids = do getCorrector (Just uid) | Just (User{..},loadMap) <- Map.lookup uid correctorMap = (nameEmailWidget userEmail userDisplayName userSurname, loadMap) - | Just (User{..} ) <- Map.lookup uid lecturerNames - = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases + -- | Just (User{..} ) <- Map.lookup uid lecturerNames + -- = (nameEmailWidget userEmail userDisplayName userSurname, mempty) -- lecturers may also correct in rare cases getCorrector _ = ([whamlet|_{MsgNoCorrectorAssigned}|], mempty) -- avoid nestes hamlet $maybe with duplicated $nothing getCorrSheetStatus :: Maybe UserId -> SheetName -> Maybe CorrectionInfo diff --git a/src/Handler/Utils/Corrections.hs b/src/Handler/Utils/Corrections.hs index ca5d433d7..2fd58de80 100644 --- a/src/Handler/Utils/Corrections.hs +++ b/src/Handler/Utils/Corrections.hs @@ -30,6 +30,8 @@ instance Semigroup CorrectionInfo where mergeWith prj f = on f prj corrA corrB keepEqual (Just x) (Just y) | x==y = Just x + keepEqual Nothing other = other + keepEqual other Nothing = other keepEqual _ _ = Nothing instance Monoid CorrectionInfo where From 2073130867ffa10c3f9469643355b8dfb67fa413 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Fri, 28 Jun 2019 22:27:22 +0200 Subject: [PATCH 17/17] fix(datepicker): hide number input spinners in datepicker --- frontend/vendor/flatpickr.css | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/frontend/vendor/flatpickr.css b/frontend/vendor/flatpickr.css index 64e91f696..ffab7ba7e 100644 --- a/frontend/vendor/flatpickr.css +++ b/frontend/vendor/flatpickr.css @@ -1,3 +1,18 @@ +/* + custom code + hides the up/down arrows in time (number) inputs +*/ +/* webkit */ +.flatpickr-calendar input[type=number]::-webkit-inner-spin-button, +.flatpickr-calendar input[type=number]::-webkit-outer-spin-button { + -webkit-appearance: none; + margin: 0; +} +/* firefox */ +.flatpickr-calendar input[type=number] { + -moz-appearance:textfield; +} +/* vendor code */ .flatpickr-calendar { background: transparent; opacity: 0;