From 94436ee0e1ce2cbf13a66f9ad81883d7286acb9b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 12 Oct 2020 13:29:43 +0200 Subject: [PATCH 01/11] feat(exams): exam staff & additional schools --- messages/uniworx/de-de-formal.msg | 6 +++ messages/uniworx/en-eu.msg | 8 +++- models/exams.model | 7 ++- src/Handler/Exam/Edit.hs | 4 +- src/Handler/Exam/Form.hs | 45 ++++++++++++++++++-- src/Handler/Exam/New.hs | 3 ++ src/Handler/Exam/Show.hs | 11 ++++- src/Utils/Form.hs | 22 +++++++++- templates/exam-show.hamlet | 10 +++++ templates/exam/schoolMassInput/add.hamlet | 6 +++ templates/exam/schoolMassInput/cell.hamlet | 3 ++ templates/exam/schoolMassInput/layout.hamlet | 11 +++++ test/Database/Fill.hs | 1 + 13 files changed, 127 insertions(+), 10 deletions(-) create mode 100644 templates/exam/schoolMassInput/add.hamlet create mode 100644 templates/exam/schoolMassInput/cell.hamlet create mode 100644 templates/exam/schoolMassInput/layout.hamlet diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b59ae2ce7..0aa58cc7c 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1832,6 +1832,11 @@ ExamRoomDescription: Beschreibung ExamTimeTip: Nur zur Information der Studierenden, die tatsächliche Zeitangabe erfolgt pro Prüfungstermin/Raum ExamRoomAssigned: Zugeteilt ExamRoomRegistered: Anmeldung +ExamStaff: Prüfer/Verantwortliche Hochschullehrer +ExamStaffTip: Geben Sie bitte in jedem Fall einen Namen an, der den Prüfer/Veranstalter/Verantwortlichen Hochschullehrer eindeutig identifiziert! Sollte der Name des Prüfers allein womöglich nicht eindeutig sein, so geben Sie bitte eindeutig identifizierende Zusatzinfos, wie beispielsweise den Lehrstuhl bzw. die LFE o.Ä., an. +ExamStaffRequired: „Prüfer/Verantwortilche Hochschullehrer” muss angegeben werden +ExamExamOfficeSchools: Zusätzliche Institute +ExamExamOfficeSchoolsTip: Prüfungsbeauftragte von Instituten, die Sie hier angeben, erhalten im System (zusätzlich zum primären Institut des zugehörigen Kurses) volle Einsicht in sämtliche für diese Prüfung hinterlegten Leistungen, unabhängig von den Studiendaten der Teilnehmer. ExamOccurrenceStart: Prüfungsbeginn @@ -1841,6 +1846,7 @@ ExamFormAutomaticFunctions: Automatische Funktionen ExamFormCorrection: Korrektur ExamFormParts: Teile ExamFormMode: Ausgestaltung der Prüfung +ExamFormGrades: Prüfungsleistungen ExamModeFormNone: Keine Angabe ExamModeFormCustom: Benutzerdefiniert diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 12a20ad3c..b493635d6 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1831,6 +1831,11 @@ ExamRoomDescription: Description ExamTimeTip: Only for informational purposes. The actual times are set for each occurrence/room ExamRoomAssigned: Assigned ExamRoomRegistered: Registration +ExamStaff: Examiner/Responsible university teacher +ExamStaffTip: Please always specify a name that uniquely identifies the examiner/organiser/repsonsible university teacher! If there is a possibility that the name alone is ambiguous please also specify some additional information e.g. the professorial chair or the educational and research unit. +ExamStaffRequired: “Examiner/Responsible university teacher” must be specified +ExamExamOfficeSchools: Additional departments +ExamExamOfficeSchoolsTip: Exam offices of departments you specify here will also have full access to all results for this exam disregarding the individual participants' features of study. ExamOccurrenceStart: Exam starts @@ -1840,6 +1845,7 @@ ExamFormAutomaticFunctions: Automatic functions ExamFormCorrection: Correction ExamFormParts: Exam parts ExamFormMode: Exam design +ExamFormGrades: Exam achievements ExamModeFormNone: Not specified ExamModeFormCustom: Custom @@ -2838,4 +2844,4 @@ SystemExamOffice: Exam office SystemFaculty: Faculty member ChangelogItemFeature: Feature -ChangelogItemBugfix: Bugfix \ No newline at end of file +ChangelogItemBugfix: Bugfix diff --git a/models/exams.model b/models/exams.model index 95a5a50ab..7fbe1251d 100644 --- a/models/exams.model +++ b/models/exams.model @@ -18,6 +18,7 @@ Exam gradingMode ExamGradingMode description Html Maybe examMode ExamMode + staff Text Maybe UniqueExam course name ExamPart exam ExamId @@ -67,4 +68,8 @@ ExamCorrector ExamPartCorrector part ExamPartId corrector ExamCorrectorId - UniqueExamPartCorrector part corrector \ No newline at end of file + UniqueExamPartCorrector part corrector +ExamOfficeSchool + school SchoolId + exam ExamId + UniqueExamOfficeSchool exam school \ No newline at end of file diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 16fcc6357..ff8046788 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -49,6 +49,7 @@ postEEditR tid ssh csh examn = do , examGradingMode = efGradingMode , examDescription = efDescription , examExamMode = efExamMode + , examStaff = efStaff } when (is _Nothing insertRes) $ do @@ -80,7 +81,6 @@ postEEditR tid ssh csh examn = do , examOccurrenceDescription = eofDescription } - pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ] forM_ (Set.toList efExamParts) $ \case @@ -105,6 +105,8 @@ postEEditR tid ssh csh examn = do , examPartWeight = epfWeight } + deleteWhere [ ExamOfficeSchoolExam ==. eId ] + insertMany_ . map (flip ExamOfficeSchool eId) $ Set.toList efOfficeSchools let (invites, adds) = partitionEithers $ Set.toList efCorrectors diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 666b5af2e..1fe31be33 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -28,7 +28,6 @@ import Text.Blaze.Html.Renderer.String (renderHtml) data ExamForm = ExamForm { efName :: ExamName , efDescription :: Maybe Html - , efGradingMode :: ExamGradingMode , efStart :: Maybe UTCTime , efEnd :: Maybe UTCTime , efVisibleFrom :: Maybe UTCTime @@ -43,6 +42,9 @@ data ExamForm = ExamForm , efBonusRule :: Maybe ExamBonusRule , efOccurrenceRule :: ExamOccurrenceRule , efExamMode :: ExamMode + , efGradingMode :: ExamGradingMode + , efOfficeSchools :: Set SchoolId + , efStaff :: Maybe Text , efCorrectors :: Set (Either UserEmail UserId) , efExamParts :: Set ExamPartForm } @@ -103,7 +105,6 @@ examForm template html = do flip (renderAForm FormStandard) html $ ExamForm <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template) <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template) - <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed) <* aformSection MsgExamFormTimes <*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template) <*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template) @@ -122,11 +123,39 @@ examForm template html = do <*> examOccurrenceRuleForm (efOccurrenceRule <$> template) <* aformSection MsgExamFormMode <*> examModeForm (efExamMode <$> template) + <* aformSection MsgExamFormGrades + <*> apopt (selectField optionsFinite) (fslI MsgExamGradingMode & setTooltip MsgExamGradingModeTip) (efGradingMode <$> template <|> Just ExamGradingMixed) + <*> officeSchoolsForm (efOfficeSchools <$> template) + <*> apreq' (textField & cfStrip) (fslpI MsgExamStaff (mr MsgExamStaff) & setTooltip MsgExamStaffTip) (efStaff <$> template) <* aformSection MsgExamFormCorrection <*> examCorrectorsForm (efCorrectors <$> template) <* aformSection MsgExamFormParts <*> examPartsForm (efExamParts <$> template) +officeSchoolsForm :: Maybe (Set SchoolId) -> AForm Handler (Set SchoolId) +officeSchoolsForm mPrev = wFormToAForm $ do + currentRoute <- fromMaybe (error "officeSchoolsForm called from 404-handler") <$> getCurrentRoute + + let + miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) + miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag + + miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([SchoolId] -> FormResult [SchoolId]) + miAdd' nudge submitView csrf = do + (schoolRes, addView) <- mpopt schoolField ("" & addName (nudge "school")) Nothing + let schoolRes' = schoolRes <&> \newDat oldDat -> FormSuccess (guardOn (newDat `notElem` oldDat) newDat) + return (schoolRes', $(widgetFile "exam/schoolMassInput/add")) + + miCell' :: SchoolId -> Widget + miCell' ssh = do + School{..} <- liftHandler . runDB $ getJust ssh + $(widgetFile "exam/schoolMassInput/cell") + + miLayout' :: MassInputLayout ListLength SchoolId () + miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "exam/schoolMassInput/layout") + + fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("exam-schools" :: Text) (fslI MsgExamExamOfficeSchools & setTooltip MsgExamExamOfficeSchoolsTip) False (Set.toList <$> mPrev) + examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId)) examCorrectorsForm mPrev = wFormToAForm $ do MsgRenderer mr <- getMsgRenderer @@ -261,6 +290,7 @@ examFormTemplate (Entity eId Exam{..}) = do occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [] correctors <- selectList [ ExamCorrectorExam ==. eId ] [] invitations <- Map.keysSet <$> sourceInvitationsF @ExamCorrector eId + extraSchools <- selectList [ ExamOfficeSchoolExam ==. eId ] [] examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ @@ -308,13 +338,15 @@ examFormTemplate (Entity eId Exam{..}) = do return examCorrectorUser ] , efExamMode = examExamMode + , efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools + , efStaff = examStaff } 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 + [(Entity _ oldCourse, Entity oldExamId 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) @@ -327,6 +359,8 @@ examTemplate cid = runMaybeT $ do E.limit 1 E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ] return (course, exam) + + extraSchools <- lift $ selectList [ ExamOfficeSchoolExam ==. oldExamId ] [] oldTerm <- MaybeT . get $ courseTerm oldCourse newTerm <- MaybeT . get $ courseTerm newCourse @@ -354,6 +388,8 @@ examTemplate cid = runMaybeT $ do , efExamParts = Set.empty , efCorrectors = Set.empty , efExamMode = examExamMode oldExam + , efStaff = examStaff oldExam + , efOfficeSchools = Set.fromList $ examOfficeSchoolSchool . entityVal <$> extraSchools } @@ -431,3 +467,6 @@ validateExam cId oldExam = do ] warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode + + unless (has (_Just . _examStaff . _Nothing) oldExam) $ + guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 7b04df98a..6631977f8 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -50,6 +50,7 @@ postCExamNewR tid ssh csh = do , examPublicStatistics = efPublicStatistics , examDescription = efDescription , examExamMode = efExamMode + , examStaff = efStaff } whenIsJust insertRes $ \examid -> do insertMany_ @@ -74,6 +75,8 @@ postCExamNewR tid ssh csh = do examOccurrenceDescription = eofDescription ] + insertMany_ . map (flip ExamOfficeSchool examid) $ Set.toList efOfficeSchools + let (invites, adds) = partitionEithers $ Set.toList efCorrectors insertMany_ [ ExamCorrector{..} | let examCorrectorExam = examid diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index b90bde092..00584ff83 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -26,7 +26,7 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) <- runDB $ do + (Entity eId Exam{..}, School{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn school <- getJust examCourse >>= belongsToJust courseSchool @@ -83,7 +83,14 @@ getEShowR tid ssh csh examn = do lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) + staffInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EGradesR + + extraSchools <- E.select . E.from $ \(school' `E.InnerJoin` examOfficeSchool) -> do + E.on $ school' E.^. SchoolId E.==. examOfficeSchool E.^. ExamOfficeSchoolSchool + E.where_ $ examOfficeSchool E.^. ExamOfficeSchoolExam E.==. E.val eId + return school' + + return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown, staffInfoShown, extraSchools) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index a87f20b21..95d197cf9 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1261,8 +1261,7 @@ mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa -- Otherwise acts exactly like `mopt`. mpreq f fs@FieldSettings{..} mx = do mr <- getMessageRender - (res, fv) <- mopt f fs (Just <$> mx) - let fv' = fv { fvRequired = True } + (res, fv') <- mpreq' f fs $ Just <$> mx return $ case res of FormSuccess (Just res') -> (FormSuccess res', fv') @@ -1293,6 +1292,25 @@ wpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHa wpreq f fs mx = mFormToWForm $ mpreq f fs mx +mpreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> MForm m (FormResult (Maybe a), FieldView site) +-- ^ Pseudo required +-- +-- `FieldView` has `fvRequired` set to `True`. +-- Otherwise acts exactly like `mopt`. +mpreq' f fs mx = do + (res, fv) <- mopt f fs mx + return (res, fv { fvRequired = True }) + +apreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> AForm m (Maybe a) +apreq' f fs mx = formToAForm $ over _2 pure <$> mpreq' f fs mx + +wpreq' :: (HandlerSite m ~ site, MonadHandler m) + => Field m a -> FieldSettings site -> Maybe (Maybe a) -> WForm m (FormResult (Maybe a)) +wpreq' f fs mx = mFormToWForm $ mpreq' f fs mx + + mpopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site) -- ^ Pseudo optional diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 040b3554a..8438a1835 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -94,6 +94,16 @@ $maybe desc <- examDescription $maybe closed <- examClosed
_{MsgExamClosed} ^{isVisible False}
^{formatTimeW SelFormatDateTime closed} + $maybe staff <- examStaff + $if staffInfoShown +
_{MsgExamStaff} ^{isVisible False} +
#{staff} + $if staffInfoShown && not (onull extraSchools) +
_{MsgExamExamOfficeSchools} ^{isVisible False} +
+