feat(exams): check exam_discouraged_modes

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

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

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

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

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 $

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)

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

templates/exam-show.hamlet

@@ -20,6 +20,9 @@ $maybe desc <- examDescription
     #{desc}
 
 <section>
+  $maybe warn <- notificationDiscouragedExamMode
+    ^{warn}
+  
   <dl .deflist>
     $if not examVisible
       <dt .deflist__dt>_{MsgExamVisibleFrom}