From f74581c35648788a39d46c5a72acda4f2c2fa7b9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 26 May 2020 11:30:39 +0200 Subject: [PATCH] feat(correction): allow lecturers to set corrector Fixes #414 --- messages/uniworx/de-de-formal.msg | 6 ++ messages/uniworx/en-eu.msg | 6 ++ src/Handler/Corrections.hs | 93 +++++++++++++++++++------------ src/Handler/Utils/Form.hs | 5 ++ src/Utils/Lens.hs | 1 + 5 files changed, 74 insertions(+), 37 deletions(-) diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index f11f69118..173abe440 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 42eaaae4c..22b9216ce 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 84cbbe5fa..d32ad420e 100644 --- a/src/Handler/Corrections.hs +++ b/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 $ (,,) - <$> areq checkBoxField (fslI MsgRatingDone & setTooltip MsgRatingDoneTip) (Just $ submissionRatingDone Submission{..}) + ((corrResult, corrForm'), corrEncoding) <- runFormPost . validateForm validateCorr . identifyForm FIDcorrection . renderAForm FormStandard $ (,,,,) + <$> 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 - uid <- liftHandler requireAuthId - now <- liftIO getCurrentTime + formResult corrResult $ \(now, ratingBy', rated, ratingPoints', ratingComment') -> do + runDBJobs $ do + update sub [ SubmissionRatingBy =. ratingBy' + , SubmissionRatingTime =. (now <$ guard rated) + , SubmissionRatingPoints =. ratingPoints' + , SubmissionRatingComment =. ratingComment' + ] - 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' - , SubmissionRatingComment =. ratingComment' - ] + when (rated && is _Nothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated - - when (rated && isNothing submissionRatingTime) $ do - $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] - queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + addMessageI Success $ if + | rated -> MsgRatingUpdated + | is _Nothing ratingComment' + , is _Nothing ratingPoints' + , is _Nothing ratingBy' -> MsgRatingDeleted + | 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 - (Just _) -> do - addMessageI Success MsgRatingFilesUpdated - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + + when (is _Just res) $ do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR let heading = MsgCorrectionHead tid ssh csh shn cid headingWgt = [whamlet| diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 560dc072f..7c43e6aef 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 82a5ebd56..8b0bde094 100644 --- a/src/Utils/Lens.hs +++ b/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