feat(correction): allow lecturers to set corrector

Fixes #414

messages/uniworx/de-de-formal.msg

@@ -378,6 +378,10 @@ CorrectionsTitle: Zugewiesene Korrekturen
 CourseCorrectionsTitle: Korrekturen für diesen Kurs
 CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
 CorrectorAssignTitle: Korrektor zuweisen
+SubmissionCorrector: Korrektor
+SubmissionCorrectorTip: Der hier eingetragene Korrektor erhält vollen Zugriff auf diese Korrektur, kann sie also auch nachträglich noch verändern.
+SubmissionNoCorrector: Kein Korrektor
+SubmissionCannotBeRatedWithoutCorrector: Die Korrektur kann nur abgeschlossen werden, wenn auch ein Korrektor angegeben wird
 
 CorrectionsGrade: Korrekturen eintragen
 
@@ -655,6 +659,7 @@ RatingDone: Bewertung abgeschlossen
 RatingDoneTip: Das Korrekturergebnis ist nur dann für die Abgebenden sichtbar und kann gegen etwaige Klausur-Bonuspunkte verrechnet werden, wenn die Bewertung abgeschlossen ist.
 RatingPercent: Erreicht
 RatingFiles: Korrigierte Dateien
+RatingFilesTip: Hier hochgeladene Dateien ersetzen ggf. die bestehende korrigierte Version der Abgabe vollständig (nicht erneut hochgeladene Dateien werden gelöscht). Die original abgegebene Version bleibt erhalten. 
 PointsNotPositive: Punktzahl darf nicht negativ sein
 PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{maxPoints} sein
 PointsTooLow minPoints@Points: Punktzahl darf nicht kleiner als #{minPoints} sein
@@ -674,6 +679,7 @@ CorrectionAchievedPoints: Erzielte Punkte
 CorrectionAchievedPass: Bestanden
 FileCorrected: Korrigiert (Dateien)
 FileCorrectedDeleted: Korrigiert (gelöscht)
+RatingDraftUpdated: Korrekturentwurf gespeichert
 RatingUpdated: Korrektur gespeichert
 RatingDeleted: Korrektur zurückgesetzt
 RatingFilesUpdated: Korrigierte Dateien überschrieben

messages/uniworx/en-eu.msg

@@ -377,6 +377,10 @@ CorrectionsTitle: Assigned corrections
 CourseCorrectionsTitle: Corrections for this course
 CorrectorsHead sheetName: Correctors for #{sheetName}
 CorrectorAssignTitle: Assign corrector
+SubmissionCorrector: Corrector
+SubmissionCorrectorTip: The corrector you configure here will have full access to this correction including the right to update it in the future.
+SubmissionNoCorrector: No corrector
+SubmissionCannotBeRatedWithoutCorrector: The rating can only be marked as finished if a corrector is also configured
 
 CorrectionsGrade: Grade submissions
 
@@ -653,6 +657,7 @@ RatingDone: Rating finished
 RatingDoneTip: The rating is only visible to the submittors and considered for any exam bonuses if it is finished.
 RatingPercent: Achieved
 RatingFiles: Marked files
+RatingFilesTip: Files uploaded here completely replace any existing corrected versions (i.e. files not uploaded again are deleted). The original version as submitted will remain untouched.
 PointsNotPositive: Points may not be negative
 PointsTooHigh maxPoints: Points may not be more than #{maxPoints}
 PointsTooLow minPoints: Points may not be less than #{minPoints}
@@ -671,6 +676,7 @@ CorrectionAchievedPoints: Achieved points
 CorrectionAchievedPass: Passed
 FileCorrected: Marked (files)
 FileCorrectedDeleted: Marked (deleted)
+RatingDraftUpdated: Successfully saved correction draft
 RatingUpdated: Successfully updated correction
 RatingDeleted: Successfully reset correction
 RatingFilesUpdated: Corrected files successfully overwritten

src/Handler/Corrections.hs

@@ -34,6 +34,8 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Text as Text
 import qualified Data.CaseInsensitive as CI
 
+import qualified Control.Monad.State.Class as State
+
 -- import Data.Time
 -- import Data.Function ((&))
 --
@@ -59,8 +61,6 @@ import Database.Persist.Sql (updateWhereCount)
 
 import Data.List (genericLength)
 
-import qualified Control.Monad.State.Class as State
-
 import qualified Data.Conduit.List as C
 
 
@@ -791,11 +791,13 @@ getCorrectionR tid ssh csh shn cid = do
 postCorrectionR tid ssh csh shn cid = do
   sub <- decrypt cid
 
-  results <- runDB $ correctionData tid ssh csh shn sub
+  (results, isLecturer) <- runDB $ (,)
+    <$> correctionData tid ssh csh shn sub
+    <*> hasWriteAccessTo (CSheetR tid ssh csh shn SSubsR)
 
   MsgRenderer mr <- getMsgRenderer
   case results of
-    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
+    [(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector)] -> do
       let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
           pointsForm = case sheetType of
             NotGraded
@@ -808,59 +810,76 @@ postCorrectionR tid ssh csh shn cid = do
               -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
                       (fslpI MsgRatingPoints (mr MsgPointsPlaceholder) & setTooltip sheetType)
                       (Just submissionRatingPoints)
+          correctorForm
+            | not isLecturer = wFormToAForm $ pure . Just <$> requireAuthId
+            | otherwise = wFormToAForm $ do
+                let correctors = E.from $ \user -> do
+                      let isCorrector = E.exists . E.from $ \sheetCorrector -> 
+                            E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+                                 E.&&. sheetCorrector E.^. SheetCorrectorSheet E.==. E.val shId
+                          isLecturer'  = E.exists . E.from $ \lecturer ->
+                            E.where_ $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+                                 E.&&. lecturer E.^. LecturerCourse E.==. E.val cId
+                      E.where_ $ isCorrector E.||. isLecturer'
+                      return user
+                wopt (selectField' (Just $ SomeMessage MsgSubmissionNoCorrector) $ userOptionsE correctors) (fslI MsgSubmissionCorrector & setTooltip MsgSubmissionCorrectorTip) (Just submissionRatingBy)
+          validateCorr = do
+            (now, ratingBy', rated, ratingPoints', ratingComment') <- State.get
+            mapM_ tellValidationError $ validateRating sheetType Rating'
+              { ratingPoints  = ratingPoints'
+              , ratingComment = ratingComment'
+              , ratingTime    = guardOn rated now
+              }
+            guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated
 
-      ((corrResult, corrForm'), corrEncoding) <- runFormPost . identifyForm FIDcorrection . renderAForm FormStandard $ (,,)
+      ((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,)
-        <$> areq checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
+        <$> wFormToAForm (pure <$> liftIO getCurrentTime)
+        <*> correctorForm
+        <*> apopt checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..})
         <*> pointsForm
-        <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
+        <*> aopt (textareaField & isoField _Wrapped & cfStrip) (fslI MsgRatingComment) (Just submissionRatingComment)
       let corrForm = wrapForm' BtnSave corrForm' def
             { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
             , formEncoding = corrEncoding
             }
 
       ((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
-            areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
+            apopt (zipFileField True Nothing) (fslI MsgRatingFiles & setTooltip MsgRatingFilesTip) Nothing
       let uploadForm = wrapForm uploadForm' def
             { formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
             , formEncoding = uploadEncoding
             }
 
-      formResult corrResult $ \(rated, ratingPoints', ratingComment') -> do
+      formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do
-        uid <- liftHandler requireAuthId
+        runDBJobs $ do
-        now <- liftIO getCurrentTime
+          update sub  [ SubmissionRatingBy      =. ratingBy'
+                      , SubmissionRatingTime    =. (now <$ guard rated)
+                      , SubmissionRatingPoints  =. ratingPoints'
+                      , SubmissionRatingComment =. ratingComment'
+                      ]
 
-        if
+          when (rated && is _Nothing submissionRatingTime) $ do
-          | errs <- validateRating sheetType Rating'
+            $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
-                      { ratingPoints  = ratingPoints'
+            queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
-                      , 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'
-                            , SubmissionRatingComment =. ratingComment'
-                            ]
 
-                addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
+        addMessageI Success $ if
-
+          | rated -> MsgRatingUpdated
-                when (rated && isNothing submissionRatingTime) $ do
+          | is _Nothing ratingComment'
-                  $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
+          , is _Nothing ratingPoints'
-                  queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
+          , is _Nothing ratingBy' -> MsgRatingDeleted
-              redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+          | is _Nothing ratingComment'
+          , is _Nothing ratingPoints' -> MsgCorrectorUpdated
+          | otherwise -> MsgRatingDraftUpdated
+        redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       formResult uploadResult $ \fileUploads -> do
         uid <- maybeAuthId
 
         res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
-        case res of
+
-          Nothing  -> return () -- ErrorMessages are already added by msgSubmissionErrors
+        when (is _Just res) $ do
-          (Just _) -> do
+          addMessageI Success MsgRatingFilesUpdated
-            addMessageI Success MsgRatingFilesUpdated
+          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
-            redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       let heading = MsgCorrectionHead tid ssh csh shn cid
           headingWgt = [whamlet|

src/Handler/Utils/Form.hs

@@ -1919,3 +1919,8 @@ makeWrapped ''CourseParticipantStateIsActive
   
 courseParticipantStateIsActiveField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (SomeMessage UniWorX) -> Field m Bool
 courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (_Wrapped @CourseParticipantStateIsActive) $ radioGroupField optMsg optionsFinite
+
+
+userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User))
+             -> Handler (OptionList UserId)
+userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName

src/Utils/Lens.hs

@@ -64,6 +64,7 @@ _Maybe = iso (is _Just) (bool Nothing (Just ()))
 _CI :: FoldCase s => Iso' (CI s) s
 _CI = iso CI.original CI.mk
 
+makeWrapped ''Textarea
 
 -----------------------------------
 -- Lens Definitions for our Types