From c0b90c4c4ab9e26143c0ac76ad7af0fb4ac5fb0e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 10 Jul 2019 09:23:22 +0200 Subject: [PATCH] fix(ratings): disallow ratings for graded sheets without point value This reverts commit 1b0825c763f096c221ef464059bff13f6220f5cc. --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 66 +++++++++++++++++---------------- src/Handler/Utils/Rating.hs | 14 +++---- src/Handler/Utils/Submission.hs | 47 ++++++++++++++--------- src/Model/Rating.hs | 1 + 5 files changed, 72 insertions(+), 57 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 267c17687..ab4cb18fc 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -479,6 +479,7 @@ RatingNegative: Bewertungspunkte dürfen nicht negativ sein RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein +RatingPointsRequired: Bewertung erfordert für dieses Blatt eine Punktzahl SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index fcdcb32e4..5a9ef3796 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -710,12 +710,12 @@ postCorrectionR tid ssh csh shn cid = do results <- runDB $ correctionData tid ssh csh shn sub case results of - [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do + [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) pointsForm = case sheetType of NotGraded -> pure Nothing _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) - (fslpI MsgRatingPoints "Punktezahl") + (fslpI MsgRatingPoints "Punktezahl" & setTooltip sheetType) (Just submissionRatingPoints) ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) @@ -734,22 +734,20 @@ postCorrectionR tid ssh csh shn cid = do , formEncoding = uploadEncoding } - case corrResult of - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId - now <- liftIO getCurrentTime + formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do + uid <- liftHandlerT requireAuthId + now <- liftIO getCurrentTime - if - | errs <- validateRating sheetType Rating' - { ratingPoints = ratingPoints' - , ratingComment = ratingComment' - , ratingTime = (now <$ guard rated) - } - , not $ null errs - -> mapM_ (addMessageI Error) errs - | otherwise -> runDBJobs $ do + if + | errs <- validateRating sheetType Rating' + { ratingPoints = ratingPoints' + , ratingComment = ratingComment' + , ratingTime = (now <$ guard rated) + } + , not $ null errs + -> mapM_ (addMessageI Error) errs + | otherwise -> do + runDBJobs $ do update sub [ SubmissionRatingBy =. Just uid , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints' @@ -761,25 +759,29 @@ postCorrectionR tid ssh csh shn cid = do when (rated && isNothing submissionRatingTime) $ do $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR - - case uploadResult of - FormMissing -> return () - FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess fileUploads -> do - uid <- requireAuthId - - res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - case res of - Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors - (Just _) -> do - addMessageI Success MsgRatingFilesUpdated redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + formResult uploadResult $ \fileUploads -> do + uid <- requireAuthId + + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + case res of + Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors + (Just _) -> do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + mr <- getMessageRender let sheetTypeDesc = mr sheetType - defaultLayout $ do + heading = MsgCorrectionHead tid ssh csh shn cid + headingWgt = [whamlet| + $newline never + _{heading} + $if not (submissionRatingDone subm) + \ ^{isVisibleWidget False} + |] + siteLayout headingWgt $ do + setTitleI heading let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 6e6bebd02..472e49950 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -56,7 +56,7 @@ instance Pretty SheetGrading where validateRating :: SheetType -> Rating' -> [RatingException] -validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} +validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } | rp < 0 = [RatingNegative] | NotGraded <- ratingSheetType @@ -67,13 +67,11 @@ validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) = [RatingBinaryExpected] --- QUICKFIX: Vorkorrektur füllt keine Punkte ein und sollte trotzdem akzeptiert werden! --- Alternative: Fehler fangen und ignorieren, falls der Benutzer Dozent/Assistent/Admin ist --- validateRating ratingSheetType Rating'{ .. } --- | has _grading ratingSheetType --- , is _Nothing ratingPoints --- , isn't _Nothing ratingTime --- = [RatingPointsRequired] +validateRating ratingSheetType Rating'{ .. } + | has _grading ratingSheetType + , is _Nothing ratingPoints + , isn't _Nothing ratingTime + = [RatingPointsRequired] validateRating _ _ = [] getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 0a1e04e9c..812c2ff66 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -322,7 +322,7 @@ submissionMultiArchive (Set.toList -> ids) = do data SubmissionSinkState = SubmissionSinkState - { sinkSeenRating :: Any + { sinkSeenRating :: Last Rating' , sinkSubmissionTouched :: Any , sinkSubmissionNotifyRating :: Any , sinkFilenames :: Set FilePath @@ -481,39 +481,53 @@ sinkSubmission userId mExists isUpdate = do touchSubmission lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] - Right (submissionId', r'@Rating'{..}) -> do + Right (submissionId', r) -> do $logDebugS "sinkSubmission" $ tshow submissionId' unless (submissionId' == submissionId) $ do cID <- encrypt submissionId' throwM $ ForeignRating cID - alreadySeen <- gets $ getAny . sinkSeenRating + alreadySeen <- gets $ is (_Wrapped . _Just) . sinkSeenRating when alreadySeen $ throwM DuplicateRating - tellSt $ mempty{ sinkSeenRating = Any True } - - unless isUpdate $ throwM RatingWithoutUpdate Submission{..} <- lift $ getJust submissionId - let anyChanges = or $ - [ submissionRatingPoints /= ratingPoints - , submissionRatingComment /= ratingComment - ] + now <- liftIO getCurrentTime + let + rated = submissionRatingBy == Just userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files + r' = let Rating'{..} = r + in Rating' + { ratingTime = now <$ guard rated + , .. + } + let Rating'{..} = r' + tellSt $ mempty{ sinkSeenRating = Last $ Just r' } + + unless isUpdate $ throwM RatingWithoutUpdate + -- 'ratingTime' is ignored for consistency with 'File's: -- -- 'fileModified' is simply stored and never inspected while -- 'submissionChanged' is always set to @now@. + let anyChanges = or $ + [ submissionRatingPoints /= ratingPoints + , submissionRatingComment /= ratingComment + ] + when anyChanges $ do + touchSubmission Sheet{..} <- lift $ getJust submissionSheet - --TODO: should display errorMessages + mapM_ throwM $ validateRating sheetType r' - touchSubmission + when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } lift $ update submissionId - [ SubmissionRatingPoints =. ratingPoints + [ SubmissionRatingPoints =. ratingPoints , SubmissionRatingComment =. ratingComment + , SubmissionRatingTime =. ratingTime + , SubmissionRatingBy =. (userId <$ guard rated) -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) ] where a /~ b = not $ a ~~ b @@ -541,9 +555,8 @@ sinkSubmission userId mExists isUpdate = do case isUpdate of False -> lift . insert_ $ SubmissionEdit userId now submissionId True -> do - Submission{submissionRatingTime, submissionRatingBy} <- lift $ getJust submissionId - when (submissionRatingBy == Just userId) $ do - when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } + Submission{submissionRatingTime} <- lift $ getJust submissionId + when (is _Just submissionRatingTime) $ lift $ update submissionId [ SubmissionRatingTime =. Just now ] tellSt $ mempty{ sinkSubmissionTouched = Any True } @@ -584,7 +597,7 @@ sinkSubmission userId mExists isUpdate = do if | isUpdate - , not $ getAny sinkSeenRating + , isn't (_Wrapped . _Just) sinkSeenRating -> update submissionId [ SubmissionRatingTime =. Nothing , SubmissionRatingPoints =. Nothing diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index c7b4e910f..295d275eb 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -31,6 +31,7 @@ data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to p | RatingExceedsMax -- ^ Rating point must not exceed maximum points | RatingNotExpected -- ^ Rating not expected | RatingBinaryExpected -- ^ Rating must be 0 or 1 + | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points deriving (Show, Eq, Generic, Typeable) instance Exception RatingException