diff --git a/.hlint.yaml b/.hlint.yaml index f6a6cd81c..24e2d327e 100644 --- a/.hlint.yaml +++ b/.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} diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index c3a4f176a..5744e0781 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index f8e1ddff3..cdbf8e2f2 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index a17b30cf1..cab53a24c 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 959b38580..909e571f7 100644 --- a/src/Handler/Exam/Edit.hs +++ b/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 - { examCourse = cid - , examName = efName - , examGradingRule = efGradingRule - , examBonusRule = efBonusRule - , examOccurrenceRule = efOccurrenceRule - , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam - , examVisibleFrom = efVisibleFrom - , examRegisterFrom = efRegisterFrom - , examRegisterTo = efRegisterTo - , examDeregisterUntil = efDeregisterUntil - , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments - , examStart = efStart - , examEnd = efEnd - , examFinished = efFinished - , examClosed = examClosed oldExam - , examPublicStatistics = efPublicStatistics - , examGradingMode = efGradingMode - , examDescription = efDescription - , examExamMode = efExamMode - , examStaff = efStaff - , examPartsFrom = efPartsFrom - } + res <- trySql @ExamEditException $ do + insertRes <- myReplaceUnique eId Exam + { examCourse = cid + , examName = efName + , examGradingRule = efGradingRule + , examBonusRule = efBonusRule + , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam + , examVisibleFrom = efVisibleFrom + , examRegisterFrom = efRegisterFrom + , examRegisterTo = efRegisterTo + , examDeregisterUntil = efDeregisterUntil + , examPublishOccurrenceAssignments = efPublishOccurrenceAssignments + , examStart = efStart + , examEnd = efEnd + , examFinished = efFinished + , examClosed = examClosed oldExam + , examPublicStatistics = efPublicStatistics + , examGradingMode = efGradingMode + , examDescription = efDescription + , examExamMode = efExamMode + , 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 - Just _ -> addMessageI Error $ MsgExamNameTaken efName - Nothing -> do + return insertRes + + return . Just $ case res of + Left exc -> addMessageI Error exc + Right _ -> do addMessageI Success $ MsgExamEdited efName redirect $ CExamR tid ssh csh efName EShowR diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 90d80c17d..4c20fe692 100644 --- a/src/Handler/Exam/New.hs +++ b/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 diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index dfc09d8ac..b00dcb87d 100644 --- a/src/Utils/Sql.hs +++ b/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