From 7bc72505a4311d621af3ca46979cd95359bff621 Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 9 Nov 2018 13:59:14 +0100 Subject: [PATCH] Ratings are now validated, some refactoring --- .vscode/tasks.json | 16 ++++++++++-- ChangeLog.md | 7 ++++++ messages/uniworx/de.msg | 10 ++++++++ src/Foundation.hs | 14 ++++++----- src/Handler/Corrections.hs | 39 ++++++++++++++++------------- src/Handler/Sheet.hs | 2 +- src/Handler/Utils/Rating.hs | 42 +++++++++++--------------------- src/Handler/Utils/Submission.hs | 9 ++++--- src/Handler/Utils/Table/Cells.hs | 3 --- src/Import/NoFoundation.hs | 2 ++ src/Model/Rating.hs | 37 ++++++++++++++++++++++++++++ src/index.md | 3 +++ templates/sheetShow.hamlet | 2 +- 13 files changed, 125 insertions(+), 61 deletions(-) create mode 100644 src/Model/Rating.hs diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 88fe3a8fb..ac3e4e9ee 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -28,8 +28,20 @@ "focus": false, "panel": "dedicated", "showReuseMessage": false - }, - "problemMatcher": [] + } + }, + { + "label": "test", + "type": "shell", + "command": "./test.sh", + "group": "test", + "presentation": { + "echo": true, + "reveal": "always", + "focus": true, + "panel": "dedicated", + "showReuseMessage": false + } } ] } \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md index e5e39dee3..8448a5c55 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ + * Version 09.11.2018 + + Bugfix: Zahlreiche Knöpfe/Formulare funktionieren wieder bei eingeschaltetem Javascript + + Verschiedene Verbesserungen für Korrektoren + + * Version 19.10.2018 Benutzer können sich in der Testphase komplett selbst löschen diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bf3acc5d3..6b9c99c63 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -274,6 +274,16 @@ RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben +RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc} +RatingMissingSeparator: Could not split rating header from comments +RatingMultiple: Encountered multiple point values in rating +RatingInvalid parseErr@String: Failed to parse rating point value #{parseErr} +RatingFileIsDirectory: We do not expect this to, it's included for totality +RatingNegative: Rating points must be non-negative +RatingExceedsMax: Rating point must not exceed maximum points +RatingNotExpected: Rating not expected +RatingBinaryExpected: Rating must be 0 or 1 + NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter diff --git a/src/Foundation.hs b/src/Foundation.hs index 5b7ec8500..6dbc131bf 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -220,14 +220,16 @@ embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''CorrectorState id +embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) -embedRenderMessage ''UniWorX ''SheetType ("SheetType" <>) -newtype SheetTypeComplete = SheetTypeComplete SheetType -instance RenderMessage UniWorX (SheetTypeComplete) where - renderMessage foundation ls (SheetTypeComplete sheetType) = case sheetType of - NotGraded -> mr NotGraded - other -> mr (grading other) <> ", " <> mr other +newtype SheetTypeHeader = SheetTypeHeader SheetType +embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) + +instance RenderMessage UniWorX (SheetType) where + renderMessage foundation ls sheetType = case sheetType of + NotGraded -> mr $ SheetTypeHeader NotGraded + other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other) where mr :: RenderMessage UniWorX msg => msg -> Text mr = renderMessage foundation ls diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index d89257eee..e97f93c9e 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -500,26 +500,31 @@ postCorrectionR tid ssh csh shn cid = do case corrResult of FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs - FormSuccess (rated, ratingPoints', ratingComment') -> do - runDBJobs $ do - uid <- liftHandlerT requireAuthId - now <- liftIO getCurrentTime - - update sub [ SubmissionRatingBy =. (uid <$ guard rated) --- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload --- , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes? - , SubmissionRatingTime =. (now <$ guard rated) - , SubmissionRatingPoints =. ratingPoints' - , SubmissionRatingComment =. ratingComment' - ] + FormSuccess (rated, ratingPoints', ratingComment') + | errs <- validateRating sheetType Rating' + { ratingPoints=ratingPoints' + , ratingComment=ratingComment' + , ratingTime=Nothing + } + -> mapM_ (addMessageI Error) errs + | otherwise -> do + runDBJobs $ do + uid <- liftHandlerT requireAuthId + now <- liftIO getCurrentTime + + update sub [ SubmissionRatingBy =. Just uid + , SubmissionRatingTime =. (now <$ guard rated) + , SubmissionRatingPoints =. ratingPoints' + , SubmissionRatingComment =. ratingComment' + ] - addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated + addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated - when (rated && isNothing submissionRatingTime) $ do - $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] - queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub + when (rated && isNothing submissionRatingTime) $ do + $logDebugS "CorrectionR" [st|Rated #{tshow sub}|] + queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of FormMissing -> return () diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 97ef5fcfb..b40e165de 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -162,7 +162,7 @@ getSheetListR tid ssh csh = do , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) - $ \(Entity _ Sheet{..}, _, _) -> i18nCell $ SheetTypeComplete sheetType + $ \(Entity _ Sheet{..}, _, _) -> i18nCell sheetType , sortable Nothing (i18nCell MsgSubmission) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 269fd927a..be259344f 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -2,6 +2,7 @@ module Handler.Utils.Rating ( Rating(..), Rating'(..) + , validateRating , getRating , formatRating , ratingFile @@ -15,12 +16,10 @@ module Handler.Utils.Rating import Import - import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import Control.Monad.Trans.Maybe -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text.Encoding.Error (UnicodeException(..)) @@ -35,9 +34,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString import Text.Read (readEither) -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - import System.FilePath import qualified System.FilePath.Cryptographic as FilePath (decrypt) @@ -61,29 +57,19 @@ instance Pretty SheetGrading where pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) -data Rating = Rating - { ratingCourseName :: CourseName - , ratingSheetName :: SheetName - , ratingCorrectorName :: Maybe Text - , ratingSheetType :: SheetType - , ratingValues :: Rating' - } deriving (Read, Show, Eq, Generic, Typeable) - -data Rating' = Rating' - { ratingPoints :: Maybe Points - , ratingComment :: Maybe Text - , ratingTime :: Maybe UTCTime - } deriving (Read, Show, Eq, Generic, Typeable) - -data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode - | RatingMissingSeparator -- ^ Could not split rating header from comments - | RatingMultiple -- ^ Encountered multiple point values in rating - | RatingInvalid String -- ^ Failed to parse rating point value - | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality - deriving (Show, Eq, Generic, Typeable) - -instance Exception RatingException - +validateRating :: SheetType -> Rating' -> [RatingException] +validateRating ratingSheetType Rating'{ratingPoints=Just rp, ..} + | rp < 0 + = [RatingNegative] + | NotGraded <- ratingSheetType + = [RatingNotExpected] + | (Just maxPoints ) <- ratingSheetType ^? _grading . _maxPoints + , rp > maxPoints + = [RatingExceedsMax] + | (Just PassBinary) <- ratingSheetType ^? _grading + , not (rp == 0 || rp == 1) + = [RatingBinaryExpected] +validateRating _ _ = [] getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) getRating submissionId = runMaybeT $ do diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index e6cbe3c37..c1e2648c5 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -395,7 +395,7 @@ sinkSubmission userId mExists isUpdate = do touchSubmission lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] - Right (submissionId', Rating'{..}) -> do + Right (submissionId', r'@Rating'{..}) -> do $logDebugS "sinkSubmission" $ tshow submissionId' unless (submissionId' == submissionId) $ do @@ -417,9 +417,12 @@ sinkSubmission userId mExists isUpdate = do -- 'ratingTime' is ignored for consistency with 'File's: -- -- 'fileModified' is simply stored and never inspected while - -- 'submissionChanged' is always set to @now@. - + -- 'submissionChanged' is always set to @now@. when anyChanges $ do + + Sheet{..} <- lift $ getJust submissionSheet + mapM_ throwM $ validateRating sheetType r' + touchSubmission lift $ update submissionId [ SubmissionRatingPoints =. ratingPoints diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 8dc0e38ee..85d8571f7 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -83,9 +83,6 @@ sheetCell crse shn = link= CSheetR tid ssh csh shn SShowR in anchorCell link $ display2widget shn -sheetTypeCell :: IsDBTable m a => SheetType -> DBCell m a -sheetTypeCell sheetType = i18nCell $ SheetTypeComplete sheetType - submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a submissionCell crse shn sid = let tid = crse ^. _1 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 9d80282a3..7ad1135ca 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -7,6 +7,7 @@ import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJS import Model as Import import Model.Types.JSON as Import import Model.Migration as Import +import Model.Rating as Import import Settings as Import import Settings.StaticFiles as Import import Yesod.Auth as Import @@ -37,6 +38,7 @@ import GHC.Generics as Import (Generic) import Data.Hashable as Import import Data.List.NonEmpty as Import (NonEmpty(..)) +import Data.Text.Encoding.Error as Import(UnicodeException(..)) import Control.Monad.Morph as Import (MFunctor(..)) diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs new file mode 100644 index 000000000..6ce7760f5 --- /dev/null +++ b/src/Model/Rating.hs @@ -0,0 +1,37 @@ +module Model.Rating where + +import ClassyPrelude.Yesod +import Model + +-- import Data.Text (Text) +import Data.Text.Encoding.Error (UnicodeException(..)) +import GHC.Generics (Generic) +import Data.Typeable (Typeable) + + +data Rating = Rating + { ratingCourseName :: CourseName + , ratingSheetName :: SheetName + , ratingCorrectorName :: Maybe Text + , ratingSheetType :: SheetType + , ratingValues :: Rating' + } deriving (Read, Show, Eq, Generic, Typeable) + +data Rating' = Rating' + { ratingPoints :: Maybe Points + , ratingComment :: Maybe Text + , ratingTime :: Maybe UTCTime + } deriving (Read, Show, Eq, Generic, Typeable) + +data RatingException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode + | RatingMissingSeparator -- ^ Could not split rating header from comments + | RatingMultiple -- ^ Encountered multiple point values in rating + | RatingInvalid String -- ^ Failed to parse rating point value + | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality + | RatingNegative -- ^ Rating points must be non-negative + | RatingExceedsMax -- ^ Rating point must not exceed maximum points + | RatingNotExpected -- ^ Rating not expected + | RatingBinaryExpected -- ^ Rating must be 0 or 1 + deriving (Show, Eq, Generic, Typeable) + +instance Exception RatingException diff --git a/src/index.md b/src/index.md index 2fcfbeaa6..563023e8b 100644 --- a/src/index.md +++ b/src/index.md @@ -97,6 +97,9 @@ CryptoID Model.Migration : Manuelle Datenbank-Migration +Model.Rating + : Types for Submission Ratings that the Database does not depend on, but needed in Foundation + Jobs : `handleJobs` worker thread handling background jobs `JobQueueException` diff --git a/templates/sheetShow.hamlet b/templates/sheetShow.hamlet index 7776c0bc8..9efdc5e24 100644 --- a/templates/sheetShow.hamlet +++ b/templates/sheetShow.hamlet @@ -18,7 +18,7 @@ $maybe descr <- sheetDescription sheet
_{MsgSheetSolutionFrom}
#{solution}
_{MsgSheetType} -
_{SheetTypeComplete (sheetType sheet)} +
_{sheetType sheet} $if CorrectorSubmissions == sheetSubmissionMode sheet
_{MsgSheetPseudonym}