From ca29a66330a977a1f28bbdbe9a733aef10371427 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 26 Oct 2020 16:27:02 +0100 Subject: [PATCH 1/2] fix(exams): error messages for foreign key constraint violations --- messages/uniworx/de-de-formal.msg | 2 ++ messages/uniworx/en-eu.msg | 2 ++ src/Handler/Exam/Edit.hs | 25 +++++++------- src/Handler/Exam/Form.hs | 56 +++++++++++++++++++++++++------ src/Handler/Exam/New.hs | 23 +++++++------ src/Utils.hs | 12 +++---- 6 files changed, 80 insertions(+), 40 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6d76bf8c5..27e53f34e 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index e823b35ba..437215ed3 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 7478479a4..7cc3ef518 100644 --- a/src/Handler/Exam/Edit.hs +++ b/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 - (cid, exam) <- fetchCourseIdExam tid ssh csh examn + (template, (editExamAct, (editExamWidget, editExamEnctype))) <- runDBJobs $ do + (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 - - formResult editExamResult $ \ExamForm{..} -> do - insertRes <- runDBJobs $ do + editExamAct <- formResultMaybe editExamResult $ \ExamForm{..} -> 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 - Just _ -> addMessageI Error $ MsgExamNameTaken efName - Nothing -> do - addMessageI Success $ MsgExamEdited efName - redirect $ CExamR tid ssh csh efName EShowR + return (template, (editExamAct, (editExamWidget, editExamEnctype))) + + sequence_ editExamAct let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template diff --git a/src/Handler/Exam/Form.hs b/src/Handler/Exam/Form.hs index 1fe31be33..2a19dfa4f 100644 --- a/src/Handler/Exam/Form.hs +++ b/src/Handler/Exam/Form.hs @@ -98,11 +98,14 @@ deriveJSON defaultOptions } ''ExamOccurrenceForm -examForm :: Maybe ExamForm -> Form ExamForm -examForm template html = do +examForm :: ( MonadHandler m + , 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 diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index 3477273f0..43b7b287e 100644 --- a/src/Handler/Exam/New.hs +++ b/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 - insertRes <- runDBJobs $ do + newExamAct <- formResultMaybe newExamResult $ \ExamForm{..} -> 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 - case insertRes of - Nothing -> addMessageI Error $ MsgExamNameTaken efName - Just _ -> do - addMessageI Success $ MsgExamCreated efName - redirect $ CourseR tid ssh csh CExamListR + return . Just $ case insertRes of + Nothing -> addMessageI Error $ MsgExamNameTaken efName + Just _ -> do + addMessageI Success $ MsgExamCreated efName + redirect $ CourseR tid ssh csh CExamListR + + return (newExamAct, (newExamWidget, newExamEnctype)) + + sequence_ newExamAct let heading = prependCourseTitle tid ssh csh MsgExamNew diff --git a/src/Utils.hs b/src/Utils.hs index 966f0e27c..b1c07a348 100644 --- a/src/Utils.hs +++ b/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 = Fold.foldr and2M (return True) -orM = Fold.foldr or2M (return False) +andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool +andM = ofoldl' and2M (return True) +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 xs f = andM $ fmap f xs -anyM xs f = orM $ fmap f xs +allM, anyM :: (MonoFoldable mono, Monad m) => mono -> (Element mono -> m Bool) -> m Bool +allM xs f = andM . fmap f $ otoList 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 From 3ff2cf1fec1bf582fe1d5e1f6ee08dcc85d6bc00 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 27 Oct 2020 10:15:31 +0100 Subject: [PATCH 2/2] fix: work around conduit-bug releasing fh to early --- nixpkgs.nix | 4 ++-- src/Utils/Files.hs | 25 +++++++++++++++++++++++-- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/nixpkgs.nix b/nixpkgs.nix index 375c84162..6a21dfbda 100644 --- a/nixpkgs.nix +++ b/nixpkgs.nix @@ -4,7 +4,7 @@ import ((nixpkgs {}).fetchFromGitHub { owner = "NixOS"; repo = "nixpkgs"; - rev = "bc00ecedfa709f4fa91d445dd76ecd792cb2c728"; - sha256 = "0plhwb04srr4b0h7w8qlqi207a19szz2wqz6r4gmic856jlkchaa"; + rev = "a7a1447e5d40a9ad90983d33e151f5474eddeed9"; + sha256 = "1zb8wgsq9grrsdcz81y08h45rj8i5r8ckjhg2cv1cqmam4dczcrf"; fetchSubmodules = true; }) diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index 3b334391c..f5251825e 100644 --- a/src/Utils/Files.hs +++ b/src/Utils/Files.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module Utils.Files ( sinkFile, sinkFiles , sinkFile', sinkFiles' @@ -35,6 +37,8 @@ import qualified Database.Esqueleto.Utils as E import Data.Conduit.Algorithms.FastCDC (fastCDC) +import Control.Monad.Trans.Cont + sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => Bool -- ^ Replace? Use only in serializable transaction @@ -43,14 +47,16 @@ sinkFileDB :: (MonadCatch m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnlif sinkFileDB doReplace fileContentContent = do chunkingParams <- getsYesod $ view _appFileChunkingParams - let sinkChunk fileContentChunkContent = do + let sinkChunk !fileContentChunkContent = do fileChunkLockTime <- liftIO getCurrentTime fileChunkLockInstance <- getsYesod appInstanceID observeSunkChunk StorageDB $ olength fileContentChunkContent tellM $ Set.singleton <$> insert FileChunkLock{ fileChunkLockHash = fileContentChunkHash, .. } + existsChunk <- lift $ exists [FileContentChunkHash ==. fileContentChunkHash] + let setContentBased = updateWhere [FileContentChunkHash ==. fileContentChunkHash] [FileContentChunkContentBased =. fileContentChunkContentBased] if | existsChunk -> lift setContentBased | otherwise -> lift . handleIfSql isUniqueConstraintViolation (const setContentBased) $ @@ -144,7 +150,22 @@ sinkFile File{ fileContent = Nothing, .. } = return FileReference , fileReferenceModified = fileModified } sinkFile File{ fileContent = Just fileContentContent, .. } = do - (unsealConduitT -> fileContentContent', isEmpty) <- fileContentContent $$+ is _Nothing <$> C.peekE + chunk <- liftIO newEmptyTMVarIO + sourceAsync <- allocateLinkedAsync . runConduit $ fileContentContent .| C.mapM_ (atomically . putTMVar chunk) + + isEmpty <- atomically $ + False <$ readTMVar chunk + <|> True <$ waitSTM sourceAsync + + let fileContentContent' = evalContT . callCC $ \finishConsume -> forever $ do + inpChunk <- atomically $ + Right <$> takeTMVar chunk + <|> Left <$> waitCatchSTM sourceAsync + + case inpChunk of + Right inpChunk' -> lift $ yield inpChunk' + Left (Left exc) -> throwM exc + Left (Right res) -> finishConsume res fileContentHash <- if | not isEmpty -> maybeT (sinkFileDB False fileContentContent') $ sinkFileMinio fileContentContent'