fix(exams): error messages for foreign key constraint violations

messages/uniworx/de-de-formal.msg

@@ -1950,6 +1950,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName@ExamOccurrenceName: Beginn des Te
 ExamOccurrenceEndMustBeBeforeExamEnd eoName@ExamOccurrenceName: Ende des Termins #{eoName} liegt nach dem Ende der Prüfung
 ExamOccurrenceDuplicate eoRoom@Text eoRange@Text: Raum #{eoRoom}, Termin #{eoRange} kommt mehrfach mit der selben Beschreibung vor
 ExamOccurrenceDuplicateName eoName@ExamOccurrenceName: Interne Terminbezeichnung #{eoName} kommt mehrfach vor
+ExamOccurrenceCannotBeDeletedDueToRegistrations eoName@ExamOccurrenceName: Termin #{eoName} kann nicht gelöscht werden, da noch Teilnehmer diesem Termin zugewiesen sind. Über die Liste von Prüfungsteilnehmern können Sie zunächst die entsprechenden Terminzuweisungen entfernen.
+ExamPartCannotBeDeletedDueToResults exampartnum@ExamPartNumber: Teil #{exampartnum} kann nicht gelöscht werden, da bereits Prüfungsergebnisse für diesen Teil eingetragen wurden.
 
 VersionHistory: Versionsgeschichte
 KnownBugs: Bekannte Bugs

messages/uniworx/en-eu.msg

@@ -1949,6 +1949,8 @@ ExamOccurrenceStartMustBeAfterExamStart eoName: Start of the occurrence #{eoName
 ExamOccurrenceEndMustBeBeforeExamEnd eoName: End of the occurrence #{eoName} must be before the exam end
 ExamOccurrenceDuplicate eoRoom eoRange: Combination of room #{eoRoom} and occurrence #{eoRange} occurs multiple times
 ExamOccurrenceDuplicateName eoName: Internal name #{eoName} occurs multiple times
+ExamOccurrenceCannotBeDeletedDueToRegistrations eoName: Occurrence #{eoName} cannot be deleted because participants are registered for it. You can remove the offending registrations via the list of exam participants.
+ExamPartCannotBeDeletedDueToResults exampartnum: Part #{exampartnum} cannot be deleted because some exam part results were already entered for it.
 
 VersionHistory: Version history
 KnownBugs: Known bugs

src/Handler/Exam/Edit.hs

@@ -18,17 +18,14 @@ import Jobs.Queue
 getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEEditR = postEEditR
 postEEditR tid ssh csh examn = do
-  (cid, Entity eId oldExam, template) <- runDB $ do
+  (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do
-    (cid, exam) <- fetchCourseIdExam tid ssh csh examn
+    (cid, exam@(Entity eId oldExam)) <- fetchCourseIdExam tid ssh csh examn
 
     template <- examFormTemplate exam
 
-    return (cid, exam, template)
+    ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm $ Just template
 
-  ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just oldExam) . examForm $ Just template
+    editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
-
-  formResult editExamResult $ \ExamForm{..} -> do
-    insertRes <- runDBJobs $ do
       insertRes <- myReplaceUnique eId Exam
         { examCourse           = cid
         , examName             = efName
@@ -116,13 +113,15 @@ postEEditR tid ssh csh examn = do
         deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
         sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
 
-      return insertRes
+      return . Just $ case insertRes of
+        Just _  -> addMessageI Error $ MsgExamNameTaken efName
+        Nothing -> do
+          addMessageI Success $ MsgExamEdited efName
+          redirect $ CExamR tid ssh csh efName EShowR
 
-    case insertRes of
+    return (template, (editExamAct, (editExamWidget, editExamEnctype)))
-      Just _  -> addMessageI Error $ MsgExamNameTaken efName
+
-      Nothing -> do
+  sequence_ editExamAct
-        addMessageI Success $ MsgExamEdited efName
-        redirect $ CExamR tid ssh csh efName EShowR
 
   let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
 

src/Handler/Exam/Form.hs

@@ -98,11 +98,14 @@ deriveJSON defaultOptions
   } ''ExamOccurrenceForm
 
 
-examForm :: Maybe ExamForm -> Form ExamForm
+examForm :: ( MonadHandler m
-examForm template html = do
+            , HandlerSite m ~ UniWorX
+            )
+         => Maybe ExamForm -> (Html -> MForm m (FormResult ExamForm, Widget))
+examForm template csrf = hoist liftHandler $ do
   MsgRenderer mr <- getMsgRenderer
 
-  flip (renderAForm FormStandard) html $ ExamForm
+  flip (renderAForm FormStandard) csrf $ ExamForm
     <$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
     <*> aopt htmlField (fslI MsgExamDescription) (efDescription <$> template)
     <*  aformSection MsgExamFormTimes
@@ -284,7 +287,11 @@ examPartsForm prev = wFormToAForm $ do
     miIdent' :: Text
     miIdent' = "exam-parts"
 
-examFormTemplate :: Entity Exam -> DB ExamForm
+examFormTemplate :: ( MonadHandler m
+                    , HandlerSite m ~ UniWorX
+                    , MonadThrow m
+                    )
+                 => Entity Exam -> SqlPersistT m ExamForm
 examFormTemplate (Entity eId Exam{..}) = do
   examParts <- selectList [ ExamPartExam ==. eId ] []
   occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
@@ -342,7 +349,8 @@ examFormTemplate (Entity eId Exam{..}) = do
     , efStaff            = examStaff
     }
 
-examTemplate :: CourseId -> DB (Maybe ExamForm)
+examTemplate :: MonadHandler m
+             => CourseId -> SqlPersistT m (Maybe ExamForm)
 examTemplate cid = runMaybeT $ do
   newCourse <- MaybeT $ get cid
 
@@ -393,7 +401,12 @@ examTemplate cid = runMaybeT $ do
     }
 
 
-validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseId -> Maybe Exam -> FormValidator ExamForm m ()
+validateExam :: forall m.
+                ( MonadHandler m
+                , HandlerSite m ~ UniWorX
+                , MonadThrow m
+                )
+             => CourseId -> Maybe (Entity Exam) -> FormValidator ExamForm (SqlPersistT m) ()
 validateExam cId oldExam = do
   ExamForm{..} <- State.get
 
@@ -404,6 +417,7 @@ validateExam cId oldExam = do
   guardValidation MsgExamFinishedMustBeAfterEnd   $ Just False /= ((>=) <$> efFinished <*> efEnd)
   guardValidation MsgExamFinishedMustBeAfterStart $ Just False /= ((>=) <$> efFinished <*> efStart)
 
+
   forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
     guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName)       $ NTop eofEnd >= NTop (Just eofStart)
     guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
@@ -421,6 +435,28 @@ validateExam cId oldExam = do
 
     guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b
 
+  oldOccurrencesWithRegistrations <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examOccurrence -> do
+    E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
+    E.where_ . E.exists . E.from $ \examRegistration ->
+      E.where_ $ examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
+    return ( examOccurrence E.^. ExamOccurrenceId
+           , examOccurrence E.^. ExamOccurrenceName
+           )
+  forM_ (join $ hoistMaybe oldOccurrencesWithRegistrations) $ \(E.Value eoId, E.Value eoName) ->
+    guardValidationM (MsgExamOccurrenceCannotBeDeletedDueToRegistrations eoName) . anyM (otoList efOccurrences) $ \ExamOccurrenceForm{..} -> (== Just eoId) <$> traverse decrypt eofId
+
+
+  oldPartsWithResults <- for oldExam $ \(Entity eId _) -> lift . E.select . E.from $ \examPart -> do
+    E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
+    E.where_ . E.exists . E.from $ \examPartResult ->
+      E.where_ $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
+    return ( examPart E.^. ExamPartId
+           , examPart E.^. ExamPartNumber
+           )
+  forM_ (join $ hoistMaybe oldPartsWithResults) $ \(E.Value epId, E.Value epNumber) ->
+    guardValidationM (MsgExamPartCannotBeDeletedDueToResults epNumber) . anyM (otoList efExamParts) $ \ExamPartForm{..} -> (== Just epId) <$> traverse decrypt epfId
+
+
   mSchool <- liftHandler . runDB . E.selectMaybe . E.from $ \(course `E.InnerJoin` school) -> do
     E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
     E.where_ $ course E.^. CourseId E.==. E.val cId
@@ -429,7 +465,7 @@ validateExam cId oldExam = do
   whenIsJust mSchool $ \(Entity _ School{..}) -> do
     whenIsJust schoolExamMinimumRegisterBeforeStart $ \minSep -> do
       let doValidation
-            | Just Exam{..} <- oldExam
+            | Just (Entity _ Exam{..}) <- oldExam
             , not . fromMaybe True $ (>=) <$> examStart <*> (addUTCTime minSep <$> examRegisterFrom)
             = warnValidation
             | otherwise
@@ -438,7 +474,7 @@ validateExam cId oldExam = do
         . fromMaybe True $ (>=) <$> efStart <*> (addUTCTime minSep <$> efRegisterFrom)
     whenIsJust schoolExamMinimumRegisterDuration $ \minDur -> do
       let doValidation
-            | Just Exam{..} <- oldExam
+            | Just (Entity _ Exam{..}) <- oldExam
             , not . fromMaybe True $ (>=) <$> examRegisterTo <*> (addUTCTime minDur <$> examRegisterFrom)
             = warnValidation
             | otherwise
@@ -447,7 +483,7 @@ validateExam cId oldExam = do
         . fromMaybe True $ (>=) <$> efRegisterTo <*> (addUTCTime minDur <$> efRegisterFrom)
     when schoolExamRequireModeForRegistration $ do
       let doValidation
-            | Just Exam{ examExamMode = ExamMode{..}, .. } <- oldExam
+            | Just (Entity _ Exam{ examExamMode = ExamMode{..}, .. }) <- oldExam
             , or [ is _Nothing examAids
                  , is _Nothing examOnline
                  , is _Nothing examSynchronicity
@@ -468,5 +504,5 @@ validateExam cId oldExam = do
 
     warnValidation MsgExamModeSchoolDiscouraged . not $ evalExamModeDNF schoolExamDiscouragedModes efExamMode
 
-  unless (has (_Just . _examStaff . _Nothing) oldExam) $
+  unless (has (_Just . _entityVal . _examStaff . _Nothing) oldExam) $
     guardValidation MsgExamStaffRequired $ isn't _Nothing efStaff

src/Handler/Exam/New.hs

@@ -19,15 +19,13 @@ import qualified Data.Conduit.Combinators as C
 getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCExamNewR = postCExamNewR
 postCExamNewR tid ssh csh = do
-  (cid, template) <- runDB $ do
+  (newExamAct, (newExamWidget, newExamEnctype)) <- runDBJobs $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
     template <- examTemplate cid
-    return (cid, template)
 
-  ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
+    ((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm (validateExam cid Nothing) $ examForm template
 
-  formResult newExamResult $ \ExamForm{..} -> do
+    newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> do
-    insertRes <- runDBJobs $ do
       now <- liftIO getCurrentTime
 
       insertRes <- insertUnique Exam
@@ -95,12 +93,15 @@ postCExamNewR tid ssh csh = do
                 audit $ TransactionExamResultEdit examid courseParticipantUser
         runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
 
-      return insertRes
+      return . Just $ case insertRes of
-    case insertRes of
+        Nothing -> addMessageI Error $ MsgExamNameTaken efName
-      Nothing -> addMessageI Error $ MsgExamNameTaken efName
+        Just _  -> do
-      Just _  -> do
+          addMessageI Success $ MsgExamCreated efName
-        addMessageI Success $ MsgExamCreated efName
+          redirect $ CourseR tid ssh csh CExamListR
-        redirect $ CourseR tid ssh csh CExamListR
+
+    return (newExamAct, (newExamWidget, newExamEnctype))
+
+  sequence_ newExamAct
 
   let heading = prependCourseTitle tid ssh csh MsgExamNew
 

src/Utils.hs

@@ -810,14 +810,14 @@ and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
 and2M ma mb = ifM ma mb (return False)
 or2M ma = ifM ma (return True)
 
-andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool
-andM = Fold.foldr and2M (return True)
+andM = ofoldl' and2M (return True)
-orM = Fold.foldr or2M (return False)
+orM = ofoldl' or2M (return False)
 
 -- | Short-circuiting monady any
-allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool
-allM xs f = andM $ fmap f xs
+allM xs f = andM . fmap f $ otoList xs
-anyM xs f = orM $ fmap f xs
+anyM xs f = orM . fmap f $ otoList xs
 
 ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
 ofoldr1M f (otoList -> x:xs) = foldrM f x xs