fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix: prevent deleting sheet-referenced exam parts

Browse Source 
Fixes #681
This commit is contained in:
Gregor Kleen 2021-04-13 14:51:31 +02:00
parent 5c709f1bbb
commit 9859c2e99c
7 changed files with 87 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.hlint.yaml
View File

@ -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}

3
messages/uniworx/misc/de-de-formal.msg
View File

@ -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

3
messages/uniworx/misc/en-eu.msg
View File

@ -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

14
src/Database/Esqueleto/Utils.hs
View File

@ -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

86
src/Handler/Exam/Edit.hs
View File

@ -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

2
src/Handler/Exam/New.hs
View File

@ -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

4
src/Utils/Sql.hs
View File

@ -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