diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index b6003ac68..b46939abf 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1917,6 +1917,7 @@ ExamClosedMustBeAfterEnd: "Noten stehen fest ab" muss nach Ende liegen ExamRegistrationMustFollowSchoolSeparationFromStart dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Beginn" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen. ExamRegistrationMustFollowSchoolDuration dayCount@Int: Nach Regeln des Instituts #{pluralDE dayCount "muss" "müssen"} zwischen "Anmeldung ab" und "Anmeldung bis" mindestens #{dayCount} #{pluralDE dayCount "Tag" "Tage"} liegen. ExamModeRequiredForRegistration: Nach Regeln des Institus muss die "Ausgestaltung der Prüfung" vollständig angegeben sein, bevor "Anmeldung ab" festgelegt werden kann. +ExamModeSchoolDiscouraged: Nach Regeln des Instituts wird von der angegebenen "Ausgestaltung der Prüfung" abgeraten ExamOccurrenceEndMustBeAfterStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss vor seinem Ende liegen ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Termins #{eoName} muss nach Beginn der Prüfung liegen diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 2fa32d5c1..79456dd64 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1916,6 +1916,7 @@ ExamClosedMustBeAfterEnd: "Exam achievements registered" must be after "end" ExamRegistrationMustFollowSchoolSeparationFromStart dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Start". ExamRegistrationMustFollowSchoolDuration dayCount: As per school rules there #{pluralEN dayCount "needs" "need"} to be at least #{dayCount} #{pluralEN dayCount "day" "days"} between "Register from" and "Register to". ExamModeRequiredForRegistration: As per school rules "Exam design" needs to be fully specified before "Register from" may be set. +ExamModeSchoolDiscouraged: As per school rules the specified "Exam design" is discouraged ExamOccurrenceEndMustBeAfterStart eoName: End of the occurrence #{eoName} must be after it's start ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName} must be after the exam start diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 9f3d155b4..666b5af2e 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -12,6 +12,7 @@ import Handler.Exam.CorrectorInvite () import Handler.Utils import Handler.Utils.Invitations +import Handler.Utils.Exam (evalExamModeDNF) import Data.Map ((!)) import qualified Data.Map as Map @@ -428,3 +429,5 @@ validateExam cId oldExam = do , is _Just examSynchronicity , is _Just examRequiredEquipment ] + + warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index 2f206e05a..b90bde092 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -26,8 +26,9 @@ getEShowR tid ssh csh examn = do cTime <- liftIO getCurrentTime mUid <- maybeAuthId - (Entity eId Exam{..}, 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) <- runDB $ do exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn + school <- getJust examCourse >>= belongsToJust courseSchool let examVisible = NTop (Just cTime) >= NTop examVisibleFrom @@ -82,7 +83,7 @@ getEShowR tid ssh csh examn = do lecturerInfoShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR - return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) + return (exam, school, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, bonus, occurrences, (registered, mayRegister), registeredCount, lecturerInfoShown) let occurrenceNamesShown = lecturerInfoShown partNumbersShown = lecturerInfoShown @@ -174,6 +175,11 @@ getEShowR tid ssh csh examn = do let heading = prependCourseTitle tid ssh csh $ CI.original examName + notificationDiscouragedExamMode <- runMaybeT $ do + guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode + guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR + return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged + siteLayoutMsg heading $ do setTitleI heading let diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 6b7193073..2ba5695e4 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -76,7 +76,7 @@ mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template) <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template) <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template) - <*> areq (jsonField False) (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)) + <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse)) where ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text)) ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $ diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 5d2b3c0b9..1071cc435 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -12,6 +12,7 @@ module Handler.Utils.Exam , examAutoOccurrence , deregisterExamUsersCount, deregisterExamUsers , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget + , evalExamModeDNF ) where import Import @@ -657,3 +658,25 @@ examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment") + + +evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool +evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} + = dnfTerms + & map (Set.toList . toNullable) . Set.toList + & map ( maybe True (ofoldr1 (&&)) + . fromNullable + . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl) + ) + & maybe False (ofoldr1 (||)) . fromNullable + where + evalPred :: ExamModePredicate -> Bool + evalPred = \case + ExamModePredAids p + -> examAids == Just (ExamAidsPreset p) + ExamModePredOnline p + -> examOnline == Just (ExamOnlinePreset p) + ExamModePredSynchronicity p + -> examSynchronicity == Just (ExamSynchronicityPreset p) + ExamModePredRequiredEquipment p + -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index ca4f3da94..6938ef227 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -549,9 +549,11 @@ deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 , sumEncoding = TaggedObject "setting" "preset" } ''ExamModePredicate +derivePathPiece ''ExamModePredicate (camelToPathPiece' 3) "--" +deriveFinite ''ExamModePredicate newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Semigroup, Monoid, ToJSON, FromJSON) + deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece) derivePersistFieldJSON ''ExamModeDNF diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index a28c0ed51..040b3554a 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -20,6 +20,9 @@ $maybe desc <- examDescription #{desc}
+ $maybe warn <- notificationDiscouragedExamMode + ^{warn} +
$if not examVisible
_{MsgExamVisibleFrom}