diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 61c06de8d..b4e372c66 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -478,7 +478,6 @@ 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 78e33bfab..28e3a095c 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 _ subm@Submission{..}, corrector)] -> do + [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ 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" & setTooltip sheetType) + (fslpI MsgRatingPoints "Punktezahl") (Just submissionRatingPoints) ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,) @@ -734,20 +734,22 @@ postCorrectionR tid ssh csh shn cid = do , formEncoding = uploadEncoding } - formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do - uid <- liftHandlerT requireAuthId - now <- liftIO getCurrentTime + case corrResult of + FormMissing -> return () + FormFailure errs -> mapM_ (addMessage Error . toHtml) errs + FormSuccess (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 -> do - runDBJobs $ do + if + | errs <- validateRating sheetType Rating' + { ratingPoints = ratingPoints' + , ratingComment = ratingComment' + , ratingTime = (now <$ guard rated) + } + , not $ null errs + -> mapM_ (addMessageI Error) errs + | otherwise -> runDBJobs $ do update sub [ SubmissionRatingBy =. Just uid , SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingPoints =. ratingPoints' @@ -759,29 +761,25 @@ 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 - heading = MsgCorrectionHead tid ssh csh shn cid - headingWgt = [whamlet| - $newline never - _{heading} - $if not (submissionRatingDone subm) - \ ^{isVisibleWidget False} - |] - siteLayout headingWgt $ do - setTitleI heading + defaultLayout $ do let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 472e49950..2e980312f 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,11 +67,6 @@ validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } | (Just PassBinary) <- ratingSheetType ^? _grading , not (rp == 0 || rp == 1) = [RatingBinaryExpected] -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/Model/Rating.hs b/src/Model/Rating.hs index 295d275eb..c7b4e910f 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -31,7 +31,6 @@ 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