diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 793c0f393..fa4d2a2f1 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -826,7 +826,7 @@ section .allocation-course__application-label padding-top: 0 -.comment +.comment, .literal-error white-space: pre-wrap font-family: monospace diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 6555ea5a3..4ad9b7456 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -686,20 +686,27 @@ RatingUpdated: Korrektur gespeichert RatingDeleted: Korrektur zurückgesetzt RatingFilesUpdated: Korrigierte Dateien überschrieben -RatingNotUnicode uexc@UnicodeException: Bewertungsdatei nicht in UTF-8 kodiert: #{tshow uexc} +RatingNotUnicode: Bewertungsdatei konnte nicht als UTF-8 dekodiert werden: RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert werden RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe -RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr} +RatingInvalid: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: RatingFileIsDirectory: Bewertungsdatei ist unerlaubterweise ein Verzeichnis -RatingParseLegacyException renderedLegacyException@Text: Beim Interpretieren als Bewertungsdatei im veralteten Format: #{renderedLegacyException} +RatingParseException: Beim Interpretieren als Bewertungsdatei im YAML-basierten Format: +RatingParseLegacyException: Beim Interpretieren als Bewertungsdatei im veralteten Format: 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 RatingFile: Bewertungsdatei -RatingFileException file@FilePath ratingException@Text: Beim Verarbeiten von Bewertungsdatei „#{file}“ ist folgender Fehler aufgetreten: #{ratingException} -RatingSubmissionException smid@CryptoFileNameSubmission ratingException@Text: Beim Verarbeiten der Bewertungsdatei für Abgabe „#{toPathPiece smid}“ ist folgender Fehler aufgetreten: #{ratingException} +RatingFileException file@FilePath: Beim Verarbeiten von Bewertungsdatei „#{file}“ ist folgender Fehler aufgetreten: +RatingSubmissionException smid@CryptoFileNameSubmission: Beim Verarbeiten der Bewertungsdatei für Abgabe „#{toPathPiece smid}“ ist folgender Fehler aufgetreten: +RatingYAMLExceptionBeforeComment: Beim Interpretieren des YAML-Teils (zum Abtrennen des Kommentars) ist folgender Fehler aufgetreten: +RatingYAMLException: Beim Interpretieren des YAML-Teils ist folgender Fehler aufgetreten: +RatingYAMLCommentNotUnicode: Der enthaltene Kommentar konnte nicht als UTF-8 dekodiert werden: +RatingYAMLStreamTerminatedUnexpectedly: Event-Stream unerwartet abgebrochen +RatingYAMLDocumentEndIllDefined: Position des Endes des YAML-Teils nicht wohldefiniert +RatingSubmissionIDIncorrect: Die in der Bewertungsdatei enthaltene Abgabenummer passt nicht zum Dateinamen SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{file} kommt mehrfach im Zip-Archiv vor SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. @@ -2624,4 +2631,5 @@ RatingYAMLRatingComment: Bewertung RatingYAMLChangePointsComment: TODO: Hier die Punktezahl statt null eintragen (bis zu zwei Nachkommastellen, Punkt als Dezimalseparator; z.B. 17.03) RatingYAMLChangePassedComment: TODO: Hier true oder false statt null eintragen (true entspricht Bestanden) RatingYAMLChangeDoneComment: TODO: Von false auf true setzen, sobald Bewertung abgeschlossen; sonst Korrektur für die Studierenden nicht sichtbar und keine Anrechnung auf Klausurbonus -RatingYAMLChangeCommentComment: TODO: Korrektur-Kommentar für die Studierenden unterhalb der Abtrennung (...) eintragen \ No newline at end of file +RatingYAMLChangeCommentComment: TODO: Korrektur-Kommentar für die Studierenden unterhalb der Abtrennung (...) eintragen +RatingYAMLSubmissionIdComment: Abgabenummer; wird beim Hochladen mit dem Dateinamen abgeglichen \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 03bae360f..e5d84055d 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -683,20 +683,27 @@ RatingUpdated: Successfully updated correction RatingDeleted: Successfully reset correction RatingFilesUpdated: Corrected files successfully overwritten -RatingNotUnicode uexc: Marking file is not UTF-8 encoded: #{tshow uexc} +RatingNotUnicode: Marking file could not be UTF-8 decoded: RatingMissingSeparator: Preamble of the marking file could not be identified RatingMultiple: Correction contains multiple markings -RatingInvalid parseErr: Marking points could not be parsed as a number: #{parseErr} +RatingInvalid: Marking points could not be parsed as a number: RatingFileIsDirectory: Marking file must not be a directory -RatingParseLegacyException renderedLegacyException: While parsing as a rating file in legacy format: #{renderedLegacyException} +RatingParseException: While parsing as a rating file in the YAML-based format: +RatingParseLegacyException: While parsing as a rating file in legacy format: RatingNegative: Marking points may not be negative RatingExceedsMax: Marking points exceed maximum RatingNotExpected: No marking points expected for this sheet RatingBinaryExpected: Marking must be 0 (=failed) or 1(=passed) RatingPointsRequired: Marking points required for this sheet RatingFile: Marking file -RatingFileException file ratingException: While processing the rating file “#{file}” the following error occurred: #{ratingException} -RatingSubmissionException smid ratingException: While processing the rating file for the submission “#{toPathPiece smid}” the following error occurred: #{ratingException} +RatingFileException file: While processing the rating file “#{file}” the following error occurred: +RatingSubmissionException smid: While processing the rating file for the submission “#{toPathPiece smid}” the following error occurred: +RatingYAMLExceptionBeforeComment: While parsing the YAML part (to separate out the rating comment) the following error occurred: +RatingYAMLException: While parsing the YAML part the following error occurred: +RatingYAMLCommentNotUnicode: The contained rating comment could not be UTF-8 decoded: +RatingYAMLStreamTerminatedUnexpectedly: Event stream terminated unexpectedly +RatingYAMLDocumentEndIllDefined: End of YAML part has no well defined position +RatingSubmissionIDIncorrect: The submission id contained within the rating file does not match it's name SubmissionSinkExceptionDuplicateFileTitle file: File #{show file} occurs multiple files within zip-archive. SubmissionSinkExceptionDuplicateRating: Found more than one marking file @@ -2625,3 +2632,4 @@ RatingYAMLChangePointsComment: TODO: Insert number of points instead of null (up RatingYAMLChangePassedComment: TODO: Set true or false instead of null (true means passed) RatingYAMLChangeDoneComment: TODO: Set to true instead of false, when correction is finished; otherwise correction will not be visible to students and won't be counted for exam bonus RatingYAMLChangeCommentComment: TODO: Enter correction comment after the separator below (...) +RatingYAMLSubmissionIdComment: Submission id; will be compared to the filename during upload diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 3ed07be08..b95207b9b 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -204,25 +204,7 @@ embedRenderMessage ''UniWorX ''ExamGradingMode id embedRenderMessage ''UniWorX ''AuthenticationMode id -instance RenderMessage UniWorX RatingFileException where - renderMessage foundation ls = \case - RatingFileException{..} -> mr . MsgRatingFileException ratingExceptionFile $ mr ratingException - RatingSubmissionException{..} -> mr . MsgRatingSubmissionException ratingExceptionSubmission $ mr ratingException - where - mr :: RenderMessage UniWorX msg => msg -> Text - mr = renderMessage foundation ls - -embedRenderMessage ''UniWorX ''RatingParseLegacyException id -instance RenderMessage UniWorX RatingException where - renderMessage foundation ls = \case - RatingParseLegacyException legacyException -> mr . MsgRatingParseLegacyException $ mr legacyException - RatingNegative -> mr MsgRatingNegative - RatingExceedsMax -> mr MsgRatingExceedsMax - RatingNotExpected -> mr MsgRatingNotExpected - RatingBinaryExpected -> mr MsgRatingBinaryExpected - RatingPointsRequired -> mr MsgRatingPointsRequired - where mr :: RenderMessage UniWorX msg => msg -> Text - mr = renderMessage foundation ls +embedRenderMessage ''UniWorX ''RatingValidityException id newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 7871adec8..2d845e0d8 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -27,7 +27,7 @@ import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI -validateRating :: SheetType -> Rating' -> [RatingException] +validateRating :: SheetType -> Rating' -> [RatingValidityException] validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } | rp < 0 = [RatingNegative] @@ -104,14 +104,17 @@ type SubmissionContent = Either File (SubmissionId, Rating') extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadCatch m ) => ConduitT File SubmissionContent m () -extractRatings = Conduit.mapM $ \f@File{..} -> do +extractRatings = Conduit.mapM $ \f@File{..} -> liftHandler $ do msId <- isRatingFile fileTitle case () of _ | Just sId <- msId - , isJust fileContent - -> handle (throwM . RatingFileException fileTitle) $ Right . (sId, ) <$> parseRating f + , isJust fileContent -> do + (rating, cID) <- handle (throwM . RatingFileException fileTitle) $ parseRating f + sId' <- traverse decrypt cID + unless (maybe (const True) (==) sId' sId) $ + throwM $ RatingFileException fileTitle RatingSubmissionIDIncorrect + return $ Right (sId, rating) | otherwise -> return $ Left f isRatingFile :: forall m. diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs index f7bcddf98..fc1684436 100644 --- a/src/Handler/Utils/Rating/Format.hs +++ b/src/Handler/Utils/Rating/Format.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -Wno-error=deprecations #-} +{-# OPTIONS -fno-warn-orphans #-} module Handler.Utils.Rating.Format ( parseRating, formatRating @@ -33,10 +33,13 @@ import Data.List (elemIndex) import Control.Monad.Trans.State.Lazy (evalState) +import qualified System.FilePath.Cryptographic as Explicit + data PrettifyState = PrettifyInitial | PrettifyMetadata Natural + | PrettifySubmissionId | PrettifyRatingPoints | PrettifyRatingPassed | PrettifyRating @@ -48,9 +51,11 @@ data PrettifyState formatRating :: MsgRendererS UniWorX -> DateTimeFormatter -> CryptoFileNameSubmission -> Rating -> Lazy.ByteString formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = Rating'{..}, .. } = mconcat [ prettyYAML - , maybe Lazy.ByteString.empty (Lazy.Text.encodeUtf8 . Lazy.Text.fromStrict) ratingComment + , maybe Lazy.ByteString.empty (Lazy.Text.encodeUtf8 . Lazy.Text.fromStrict . ensureNewline) ratingComment ] where + ensureNewline t = Text.strip t <> "\n" + uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat [ [ YAML.Event.StreamStart , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2 @@ -73,15 +78,16 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R , pure YAML.Event.MappingEnd ] _other -> nodeEvents . str $ CI.original ratingSheetName - , mapEvents (str' "submission") (str $ toPathPiece cID) , mapEvents (str' "rated_by") (maybe (YAML.Scalar () YAML.SNull) str ratingCorrectorName) , mapEvents (str' "rated_at") (maybe (YAML.Scalar () YAML.SNull) (str . format SelFormatDateTime) ratingTime) + , mapEvents (str' "submission") (str $ toPathPiece cID) + , case ratingSheetType ^? _grading of Nothing -> mempty Just mode -> if | is _PassAlways mode -> mempty - | has _passingBound mode + | has (_passingBound . _Left) mode -> mapEvents (str' "passed") (maybe (YAML.Scalar () YAML.SNull) (YAML.Scalar () . YAML.SBool) $ gradingPassed mode =<< ratingPoints) | otherwise -> mapEvents (str' "points") (maybe (YAML.Scalar () YAML.SNull) (YAML.Scalar () . YAML.SFloat . realToFrac) ratingPoints) @@ -137,14 +143,17 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R transduce PrettifyInitial (YAML.Event.MappingStart _ _ _) = (("# " <> mr MsgRatingYAMLMetaComment <> "\n", id), PrettifyMetadata 0) transduce PrettifyInitial _ = ((mempty, id), PrettifyInitial) transduce (PrettifyMetadata 0) (YAML.Event.Scalar _ _ _ k) - | k == "points" = ((startRatingComment, id), PrettifyRatingPoints) - | k == "passed" = ((startRatingComment, id), PrettifyRatingPassed) - | k == "rating_done" = ((startRatingComment, id), PrettifyRatingDone) - where startRatingComment = "\n# " <> mr MsgRatingYAMLRatingComment <> "\n" + | k == "submission" = (("\n# " <> mr MsgRatingYAMLSubmissionIdComment <> "\n", id), PrettifySubmissionId) transduce (PrettifyMetadata n) (YAML.Event.MappingStart _ _ _) = ((mempty, id), PrettifyMetadata $ succ n) transduce (PrettifyMetadata 0) _ = ((mempty, id), PrettifyMetadata 0) transduce (PrettifyMetadata n) YAML.Event.MappingEnd = ((mempty, id), PrettifyMetadata $ pred n) transduce cState@(PrettifyMetadata _) _ = ((mempty, id), cState) + transduce PrettifySubmissionId (YAML.Event.Scalar _ _ _ k) + | k == "points" = ((startRatingComment, id), PrettifyRatingPoints) + | k == "passed" = ((startRatingComment, id), PrettifyRatingPassed) + | k == "rating_done" = ((startRatingComment, id), PrettifyRatingDone) + where startRatingComment = "\n# " <> mr MsgRatingYAMLRatingComment <> "\n" + transduce PrettifySubmissionId _ = ((mempty, id), PrettifySubmissionId) transduce PrettifyRatingPoints _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePointsComment), PrettifyRating) transduce PrettifyRatingPassed _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePassedComment), PrettifyRating) transduce PrettifyRatingDone _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangeDoneComment), PrettifyRating) @@ -162,6 +171,48 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R where (before', after) = Text.breakOnEnd "\n" ws before = Text.dropWhileEnd (== '\n') before' break' = Text.takeWhileEnd (== '\n') before' + +instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (Maybe UTCTime -> Maybe Text -> (Rating', Maybe (Explicit.CryptoFileName ns))) where + parseYAML = YAML.withMap "Rating'" $ \m -> do + ratingDone <- m YAML..:? "rating_done" YAML..!= False + ratingPoints' <- fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points" + ratingPassed <- fmap (bool 0 1) <$> m YAML..:? "passed" + let ratingPoints = ratingPoints' <|> ratingPassed + cIDNode = listToMaybe . Map.elems $ Map.filterWithKey isCIDNode m + where isCIDNode (YAML.Scalar _ (YAML.SStr k)) _ = k == "submission" + isCIDNode _ _ = False + cID <- for cIDNode $ \cIDNode' -> + YAML.withStr "CryptoFileNameSubmission" (maybe (YAML.failAtNode cIDNode' "Could not parse CryptoFileNameSubmission") return . fromPathPiece) cIDNode' + ratingComment' <- fmap (assertM' (not . Text.null) . Text.strip) <$> m YAML..:? "comment" + return $ \ratingTime ratingComment'' + -> ( Rating'{ ratingComment = fromMaybe ratingComment'' ratingComment', .. } + , cID + ) -parseRating :: MonadCatch m => File -> m Rating' -parseRating = Legacy.parseRating + +parseRating :: MonadCatch m => File -> m (Rating', Maybe CryptoFileNameSubmission) +parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFailure . handle (throwM . RatingParseException) $ do + let evStream = YAML.Event.parseEvents input + delimitDocument = do + ev <- maybe (throwM RatingYAMLStreamTerminatedUnexpectedly) return =<< await + case ev of + Right YAML.Event.EvPos{ eEvent = YAML.Event.DocumentEnd _, ePos = YAML.Event.Pos{..}} + | posByteOffset >= 0 -> return $ fromIntegral posByteOffset + | otherwise -> throwM RatingYAMLDocumentEndIllDefined + Left (pos, errStr) -> throwM . RatingYAMLExceptionBeforeComment $ YAML.prettyPosWithSource pos input errStr + Right _ -> delimitDocument + documentEnd <- runConduit $ yieldMany evStream .| delimitDocument + ratingComment <- fmap join . for (Lazy.ByteString.stripPrefix "..." $ Lazy.ByteString.drop documentEnd input) $ \cbs -> + case Lazy.Text.decodeUtf8' cbs of + Left err -> throwM $ RatingYAMLCommentNotUnicode err + Right ct -> return . assertM' (not . Text.null) . Text.strip $ toStrict ct + let yamlInput = Lazy.ByteString.take documentEnd input + case YAML.decode1 yamlInput of + Left (pos, errStr) -> throwM . RatingYAMLException $ YAML.prettyPosWithSource pos yamlInput errStr + Right cb -> return $ cb (Just fileModified) ratingComment + where + onFailure (e :: RatingException) + = ((, Nothing) <$> Legacy.parseRating f) `catch` \case + RatingParseLegacyException _ -> throwM e + other -> throwM other +parseRating _ = throwM RatingFileIsDirectory diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 4fe283fd6..6612c6f16 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -415,13 +415,11 @@ filterSubmission = do extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadCatch m ) => ConduitM File SubmissionContent m (Set FilePath) extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings extractRatingsMsg :: ( MonadHandler m , HandlerSite m ~ UniWorX - , MonadCatch m ) => ConduitT File SubmissionContent m () extractRatingsMsg = do ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings @@ -436,13 +434,79 @@ extractRatingsMsg = do -- | Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann! msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a) msgSubmissionErrors = flip catches - [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingFileException) - , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) + [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do mr <- getMessageRender addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx) return Nothing + , E.Handler $ \e -> (Nothing <$) . addMessageWidget Error $ case e of + RatingFileException{..} + -> [whamlet| + $newline never + _{MsgRatingFileException ratingExceptionFile} +
+ ^{ratingExceptionWidget ratingException} + |] + RatingSubmissionException{..} + -> [whamlet| + $newline never + _{MsgRatingSubmissionException ratingExceptionSubmission} +
+ ^{ratingExceptionWidget ratingException} + |] ] . fmap Just + where + ratingExceptionWidget = \case + RatingFileIsDirectory -> i18n MsgRatingFileIsDirectory + RatingSubmissionIDIncorrect -> i18n MsgRatingSubmissionIDIncorrect + RatingValidityException exc -> i18n exc + RatingParseException pExc + -> [whamlet| + $newline never + _{MsgRatingParseException} +
+ $case pExc + $of RatingYAMLStreamTerminatedUnexpectedly + _{MsgRatingYAMLStreamTerminatedUnexpectedly} + $of RatingYAMLDocumentEndIllDefined + _{MsgRatingYAMLDocumentEndIllDefined} + $of RatingYAMLExceptionBeforeComment errStr + _{MsgRatingYAMLExceptionBeforeComment} +
+ + #{errStr} + $of RatingYAMLException errStr + _{MsgRatingYAMLException} +
+ + #{errStr} + $of RatingYAMLCommentNotUnicode unicodeErr + _{MsgRatingYAMLCommentNotUnicode} +
+ + #{tshow unicodeErr} + |] + RatingParseLegacyException pExc + -> [whamlet| + $newline never + _{MsgRatingParseLegacyException} +
+ $case pExc + $of RatingMissingSeparator + _{MsgRatingMissingSeparator} + $of RatingMultiple + _{MsgRatingMultiple} + $of RatingInvalid errStr + _{MsgRatingInvalid} +
+ + #{errStr} + $of RatingNotUnicode unicodeErr + _{MsgRatingNotUnicode} +
+ + #{tshow unicodeErr} + |] sinkSubmission :: Maybe UserId @@ -594,7 +658,7 @@ sinkSubmission userId mExists isUpdate = do Sheet{..} <- lift . getJust $ submissionSheet submission' - mapM_ (throwM . RatingSubmissionException cID) $ validateRating sheetType r' + mapM_ (throwM . RatingSubmissionException cID . RatingValidityException) $ validateRating sheetType r' when (submissionRatingDone submission' && not (submissionRatingDone submission)) $ tellSt mempty { sinkSubmissionNotifyRating = Any True } diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index fe7cf9ced..d1ca14da4 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -24,22 +24,38 @@ data Rating' = Rating' , ratingDone :: Bool } deriving (Read, Show, Eq, Generic, Typeable) +data RatingValidityException + = 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 + | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points + deriving (Show, Eq, Generic, Typeable) + deriving anyclass (Exception) + data RatingParseLegacyException = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode | RatingMissingSeparator -- ^ Could not split rating header from comments | RatingMultiple -- ^ Encountered multiple point values in rating | RatingInvalid Text -- ^ Failed to parse rating point value - | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality + deriving (Show, Eq, Generic, Typeable) + deriving anyclass (Exception) + +data RatingParseException + = RatingYAMLStreamTerminatedUnexpectedly + | RatingYAMLDocumentEndIllDefined + | RatingYAMLExceptionBeforeComment String -- ^ Could not parse YAML to determine where rating comments begin + | RatingYAMLException String -- ^ Could not parse YAML + | RatingYAMLCommentNotUnicode UnicodeException deriving (Show, Eq, Generic, Typeable) deriving anyclass (Exception) data RatingException - = RatingParseLegacyException RatingParseLegacyException - | 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 - | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points + = RatingFileIsDirectory -- ^ We do not expect this to happen, it's included for totality + | RatingSubmissionIDIncorrect + | RatingParseException RatingParseException + | RatingParseLegacyException RatingParseLegacyException + | RatingValidityException RatingValidityException deriving (Show, Eq, Generic, Typeable) deriving anyclass (Exception) diff --git a/src/Utils.hs b/src/Utils.hs index bdf3376c1..62b9f088f 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -221,7 +221,7 @@ withFragment :: Monad m => MForm m (a, WidgetFor site ()) -> Markup -> MForm m ( withFragment form html = flip fmap form $ over _2 (toWidget html >>) rationalToFixed :: forall a. HasResolution a => Rational -> Fixed a -rationalToFixed = MkFixed . round . (* (fromIntegral $ resolution (Proxy @a))) +rationalToFixed = MkFixed . round . (* (fromInteger $ resolution (Proxy @a))) rationalToFixed3 :: Rational -> Fixed E3 rationalToFixed3 = rationalToFixed @@ -229,6 +229,9 @@ rationalToFixed3 = rationalToFixed rationalToFixed2 :: Rational -> Fixed E2 rationalToFixed2 = rationalToFixed +realToFixed :: forall a n. (HasResolution a, Real n) => n -> Fixed a +realToFixed = rationalToFixed . toRational + -- | Convert `part` and `whole` into percentage including symbol -- showing trailing zeroes and to decimal digits textPercent :: Real a => a -> a -> Text diff --git a/test/Handler/Utils/RatingSpec.hs b/test/Handler/Utils/RatingSpec.hs index c3e15031c..f1ab3c42b 100644 --- a/test/Handler/Utils/RatingSpec.hs +++ b/test/Handler/Utils/RatingSpec.hs @@ -28,7 +28,17 @@ spec = describe "Rating file parsing/pretty-printing" $ do parseRating' = either (\(_ :: SomeException) -> Nothing) Just . parseRating . flip (File "bewertung.txt") time . Just . LBS.toStrict time = UTCTime systemEpochDay 0 - mRating rating = rating { ratingValues = mRating' $ ratingValues rating } - mRating' rating' = rating' { ratingTime = Just time -- There is no field for ratingTime so we just always expect file modification time + mRating rating = rating { ratingValues = mRating' rating $ ratingValues rating } + mRating' rating rating' = rating' { ratingTime = Just time -- The field for ratingTime gets ignored, so we just always expect file modification time , ratingComment = assertM (not . Text.null) $ Text.strip <$> ratingComment rating' + , ratingPoints = normalizePoints $ ratingPoints rating' } + where + normalizePoints points + | hasn't _grading (ratingSheetType rating) || has (_grading . _PassAlways) (ratingSheetType rating) + = Nothing + | Just grading <- ratingSheetType rating ^? _grading + , has (_passingBound . _Left) grading + = fmap (bool 0 1) . gradingPassed grading =<< points + | otherwise + = points