From 463b2b78780ecf24aa3b48f0740c18fce45e8d3c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 19 Jun 2019 16:52:00 +0200 Subject: [PATCH 1/3] fix(ratings): disallow ratings for graded sheets without point value --- messages/uniworx/de.msg | 1 + src/Handler/Corrections.hs | 66 +++++++++++++++++++------------------ src/Handler/Utils/Rating.hs | 7 +++- src/Model/Rating.hs | 1 + 4 files changed, 42 insertions(+), 33 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index c0ee216ae..6ce7b8bbb 100644 --- a/messages/uniworx/de.msg +++ b/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. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index dc8cb791e..049eda984 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 _ 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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 2e980312f..472e49950 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,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) diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index c7b4e910f..295d275eb 100644 --- a/src/Model/Rating.hs +++ b/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 From 16d422d9d82467ea6e6800bee5d1af06b7fe1d3b Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Tue, 25 Jun 2019 20:45:46 +0200 Subject: [PATCH 2/3] fix(fe-deflist): avoid horizontal scroll on pages with deflist --- templates/default-layout.lucius | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 9db97efb6..6306920e2 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -502,7 +502,7 @@ ul.list--inline { @media (min-width: 768px) { .deflist { - grid-template-columns: max-content minmax(auto, max-content); + grid-template-columns: max-content minmax(0, max-content); .deflist { margin-top: -10px; From c82c3a9d80c4111b77ecda6ead30fdae25106b37 Mon Sep 17 00:00:00 2001 From: Felix Hamann Date: Tue, 25 Jun 2019 23:09:47 +0200 Subject: [PATCH 3/3] chore: small commit to get the pipeline started --- templates/default-layout.lucius | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius index 6306920e2..2fdc1b3de 100644 --- a/templates/default-layout.lucius +++ b/templates/default-layout.lucius @@ -580,7 +580,7 @@ section { justify-content: center; } } - + .form-group__input > .notification { margin: 0; }