From 67a50c9e87d3368aafe7f52a3b81e580713e6c24 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Jun 2019 15:34:09 +0200 Subject: [PATCH] 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} + + + + + $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}