fix(ratings): disallow ratings for graded sheets without point value

messages/uniworx/de.msg

@@ -464,6 +464,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.

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

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,6 +67,11 @@ 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)

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