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

This reverts commit 1b0825c763.

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.

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
+      formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
-        FormMissing -> return ()
+        uid <- liftHandlerT requireAuthId
-        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
+        now <- liftIO getCurrentTime
-        FormSuccess (rated, ratingPoints', ratingComment') -> do
-          uid <- liftHandlerT requireAuthId
-          now <- liftIO getCurrentTime
 
-          if
+        if
-            | errs <- validateRating sheetType Rating'
+          | errs <- validateRating sheetType Rating'
-                        { ratingPoints  = ratingPoints'
+                      { ratingPoints  = ratingPoints'
-                        , ratingComment = ratingComment'
+                      , ratingComment = ratingComment'
-                        , ratingTime    = (now <$ guard rated)
+                      , ratingTime    = (now <$ guard rated)
-                        }
+                      }
-            , not $ null errs
+          , not $ null errs
-              -> mapM_ (addMessageI Error) errs
+            -> mapM_ (addMessageI Error) errs
-            | otherwise -> runDBJobs $ do
+          | 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,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!
+validateRating ratingSheetType Rating'{ .. }
--- Alternative: Fehler fangen und ignorieren, falls der Benutzer Dozent/Assistent/Admin ist
+  | has _grading ratingSheetType
--- validateRating ratingSheetType Rating'{ .. }
+  , is _Nothing ratingPoints
---   | has _grading ratingSheetType
+  , isn't _Nothing ratingTime
---   , is _Nothing ratingPoints
+  = [RatingPointsRequired]
---   , isn't _Nothing ratingTime
---   = [RatingPointsRequired]
 validateRating _ _ = []
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)

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 $
+        now <- liftIO getCurrentTime
-              [ submissionRatingPoints /= ratingPoints
+        let
-              , submissionRatingComment /= ratingComment
+          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
+                Submission{submissionRatingTime} <- lift $ getJust submissionId
-                when (submissionRatingBy == Just userId) $ do
+                when (is _Just submissionRatingTime) $
-                  when (isNothing submissionRatingTime) $ tellSt mempty { sinkSubmissionNotifyRating = Any True }
                   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

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