fix(ratings): disallow ratings for graded sheets without point value
This reverts commit 1b0825c763.
This commit is contained in:
Gregor Kleen
parent
2f34d7821a
commit
c0b90c4c4a
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user