fix: prevent deleting sheet-referenced exam parts

Fixes #681

.hlint.yaml

@@ -194,3 +194,8 @@
   - warn: { lhs: n >= length xs, rhs: maxLength n xs, note: IncreasesLaziness }
   - warn: { lhs: length xs < n, rhs: maxLength (n - 1) xs, note: IncreasesLaziness }
   - warn: { lhs: n > length xs, rhs: maxLength (n - 1) xs, note: IncreasesLaziness }
+
+  - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}
+  - error: {lhs: v Database.Esqueleto.==. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.isNothing v, name: Use Esqueleto's isNothing}
+  - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.nothing, rhs: Database.Esqueleto.Utils.isJust v, name: Use Esqueleto's not isNothing}
+  - error: {lhs: v Database.Esqueleto.!=. Database.Esqueleto.val Nothing, rhs: Database.Esqueleto.Utils.isJust v, name: Use Esqueleto's not isNothing}

messages/uniworx/misc/de-de-formal.msg

@@ -2018,9 +2018,10 @@ ExamPartSheets: Übungsblätter
 ExamPartsFrom: Teile anzeigen ab
 ExamPartsFromTip: Ab dem gegebenen Zeitpunkt wird die Liste von Prüfungsteilen/Aufgaben veröffentlicht, nicht jedoch die jeweilige Maximalpunktzahl. Ohne Zeitpunkt wird die Liste ab "Ergebnisse sichtbar ab" angezeigt.
 
-ExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
+ExamEditExamNameTaken exam@ExamName: Es existiert bereits eine Prüfung mit Namen #{exam}
 ExamCreated exam@ExamName: #{exam} erfolgreich angelegt
 ExamEdited exam@ExamName: #{exam} erfolgreich bearbeitet
+ExamEditWouldBreakSheetTypeReference: Durch Ihre Änderungen würde ein Prüfungsteil gelöscht, auf den durch ein Übungsblatt noch eine Referenz besteht.
 
 ExamNoShow: Nicht erschienen
 ExamVoided: Entwertet

messages/uniworx/misc/en-eu.msg

@@ -2017,9 +2017,10 @@ ExamPartSheets: Exercise sheets
 ExamPartsFrom: Parts visible from
 ExamPartsFromTip: At this time the list of exam parts/questions will be published, but without their respective maximum number of points. If left empty the list will be published with “Results visible from”
 
-ExamNameTaken exam: There already is an exam named #{exam}
+ExamEditExamNameTaken exam: There already is an exam named #{exam}
 ExamCreated exam: Successfully created #{exam}
 ExamEdited exam: Successfully edited #{exam}
+ExamEditWouldBreakSheetTypeReference: Your changes include deleting an exam part to which a reference still exists through an exercise sheet.
 
 ExamNoShow: Not present
 ExamVoided: Voided

src/Database/Esqueleto/Utils.hs

@@ -32,6 +32,7 @@ module Database.Esqueleto.Utils
   , selectMaybe
   , day, diffDays, diffTimes
   , exprLift
+  , explicitUnsafeCoerceSqlExprValue 
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -55,6 +56,8 @@ import Data.Coerce (Coercible)
 
 import Data.Time.Clock (NominalDiffTime)
 
+import qualified Data.Text.Lazy.Builder as Text.Builder
+
 {-# ANN any ("HLint: ignore Use any" :: String) #-}
 {-# ANN all ("HLint: ignore Use all" :: String) #-}
 
@@ -130,6 +133,17 @@ substring (E.ERaw p1 f1) (E.ERaw p2 f2) (E.ERaw p3 f3)
           )
 substring a b c = substring (construct a) (construct b) (construct c)
 
+explicitUnsafeCoerceSqlExprValue :: forall b a.
+                                    Text
+                                 -> E.SqlExpr (E.Value a)
+                                 -> E.SqlExpr (E.Value b)
+explicitUnsafeCoerceSqlExprValue typ (E.ERaw p1 f1) = E.ERaw E.Parens $ \info ->
+  let (valTLB, valVals) = f1 info
+   in ( E.parensM p1 valTLB <> " :: " <> Text.Builder.fromText typ
+      , valVals
+      )
+explicitUnsafeCoerceSqlExprValue typ val = explicitUnsafeCoerceSqlExprValue typ $ construct val
+
 construct :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
 construct (E.ERaw p f)        = E.ERaw E.Parens $ \info ->
   let (b1, vals) = f info

src/Handler/Exam/Edit.hs

@@ -14,6 +14,18 @@ import Handler.Utils.Invitations
 
 import Jobs.Queue
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Utils as E
+
+
+data ExamEditException
+  = ExamEditExamNameTaken ExamName
+  | ExamEditWouldBreakSheetTypeReference
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+  deriving anyclass (Exception)
+
+embedRenderMessage ''UniWorX ''ExamEditException id
+
 
 getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
 getEEditR = postEEditR
@@ -27,31 +39,34 @@ postEEditR tid ssh csh examn = do
     ((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm (validateExam cid $ Just exam) . examForm course $ Just template
 
     editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> do
-      insertRes <- myReplaceUnique eId Exam
+      res <- trySql @ExamEditException $ do
-        { examCourse           = cid
+        insertRes <- myReplaceUnique eId Exam
-        , examName             = efName
+          { examCourse           = cid
-        , examGradingRule      = efGradingRule
+          , examName             = efName
-        , examBonusRule        = efBonusRule
+          , examGradingRule      = efGradingRule
-        , examOccurrenceRule   = efOccurrenceRule
+          , examBonusRule        = efBonusRule
-        , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam
+          , examOccurrenceRule   = efOccurrenceRule
-        , examVisibleFrom      = efVisibleFrom
+          , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam
-        , examRegisterFrom     = efRegisterFrom
+          , examVisibleFrom      = efVisibleFrom
-        , examRegisterTo       = efRegisterTo
+          , examRegisterFrom     = efRegisterFrom
-        , examDeregisterUntil  = efDeregisterUntil
+          , examRegisterTo       = efRegisterTo
-        , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
+          , examDeregisterUntil  = efDeregisterUntil
-        , examStart            = efStart
+          , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
-        , examEnd              = efEnd
+          , examStart            = efStart
-        , examFinished         = efFinished
+          , examEnd              = efEnd
-        , examClosed           = examClosed oldExam
+          , examFinished         = efFinished
-        , examPublicStatistics = efPublicStatistics
+          , examClosed           = examClosed oldExam
-        , examGradingMode      = efGradingMode
+          , examPublicStatistics = efPublicStatistics
-        , examDescription      = efDescription
+          , examGradingMode      = efGradingMode
-        , examExamMode         = efExamMode
+          , examDescription      = efDescription
-        , examStaff            = efStaff
+          , examExamMode         = efExamMode
-        , examPartsFrom        = efPartsFrom
+          , examStaff            = efStaff
-        }
+          , examPartsFrom        = efPartsFrom
+          }
+
+        when (is _Just insertRes) $
+          throwM $ ExamEditExamNameTaken efName
 
-      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
@@ -83,6 +98,21 @@ postEEditR tid ssh csh examn = do
               }
 
         pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
+
+        brokenRefs <- E.selectExists . E.from $ \examPart -> do
+          E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
+               E.&&. examPart E.^. ExamPartId `E.notIn` E.valList pIds
+          E.where_ . E.exists . E.from $ \sheet -> do
+            let
+              sheetTypeExamPart :: E.SqlExpr (E.Value (Maybe Value))
+              sheetTypeExamPart = sheet E.^. SheetType E.->. "exam-part"
+              examPartId' :: E.SqlExpr (E.Value Value)
+              examPartId' = E.explicitUnsafeCoerceSqlExprValue @Value "jsonb" . E.explicitUnsafeCoerceSqlExprValue @Text "text" $ examPart E.^. ExamPartId
+            E.where_ $ E.maybe E.false (E.==. examPartId') sheetTypeExamPart
+
+        when brokenRefs $
+          throwM ExamEditWouldBreakSheetTypeReference
+  
         deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
         forM_ (Set.toList efExamParts) $ \case
           ExamPartForm{ epfId = Nothing, .. } -> insert_
@@ -118,9 +148,11 @@ postEEditR tid ssh csh examn = do
         deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
         sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
 
-      return . Just $ case insertRes of
+        return insertRes
-        Just _  -> addMessageI Error $ MsgExamNameTaken efName
+
-        Nothing -> do
+      return . Just $ case res of
+        Left exc -> addMessageI Error exc
+        Right _ -> do
           addMessageI Success $ MsgExamEdited efName
           redirect $ CExamR tid ssh csh efName EShowR
 

src/Handler/Exam/New.hs

@@ -98,7 +98,7 @@ postCExamNewR tid ssh csh = do
         runConduit $ selectSource [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantInactive True ] [] .| C.mapM_ recordNoShow
 
       return . Just $ case insertRes of
-        Nothing -> addMessageI Error $ MsgExamNameTaken efName
+        Nothing -> addMessageI Error $ MsgExamEditExamNameTaken efName
         Just _  -> do
           addMessageI Success $ MsgExamCreated efName
           redirect $ CourseR tid ssh csh CExamListR

src/Utils/Sql.hs

@@ -5,6 +5,7 @@ module Utils.Sql
   , catchSql, handleSql
   , isUniqueConstraintViolation
   , catchIfSql, handleIfSql
+  , trySql
   ) where
 
 import ClassyPrelude.Yesod hiding (handle)
@@ -125,5 +126,8 @@ catchIfSql p = flip $ handleIfSql p
 handleIfSql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => (e -> Bool) -> (e -> SqlPersistT m a) -> SqlPersistT m a -> SqlPersistT m a
 handleIfSql p recover = handleSql (\err -> bool throwM recover (p err) err)
 
+trySql :: forall e m a. (MonadCatch m, MonadIO m, Exception e) => SqlPersistT m a -> SqlPersistT m (Either e a)
+trySql = handleSql (return . Left) . fmap Right
+
 isUniqueConstraintViolation :: SqlError -> Bool
 isUniqueConstraintViolation SqlError{..} = "duplicate key value violates unique constraint" `ByteString.isPrefixOf` sqlErrorMsg