feat(ratings): parsing for new format
This commit is contained in:
Gregor Kleen
parent
2bf484609e
commit
af7947328d
@ -826,7 +826,7 @@ section
|
||||
.allocation-course__application-label
|
||||
padding-top: 0
|
||||
|
||||
.comment
|
||||
.comment, .literal-error
|
||||
white-space: pre-wrap
|
||||
font-family: monospace
|
||||
|
||||
|
||||
@ -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
|
||||
RatingYAMLChangeCommentComment: TODO: Korrektur-Kommentar für die Studierenden unterhalb der Abtrennung (...) eintragen
|
||||
RatingYAMLSubmissionIdComment: Abgabenummer; wird beim Hochladen mit dem Dateinamen abgeglichen
|
||||
@ -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
|
||||
|
||||
@ -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" <>)
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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}
|
||||
<br>
|
||||
^{ratingExceptionWidget ratingException}
|
||||
|]
|
||||
RatingSubmissionException{..}
|
||||
-> [whamlet|
|
||||
$newline never
|
||||
_{MsgRatingSubmissionException ratingExceptionSubmission}
|
||||
<br>
|
||||
^{ratingExceptionWidget ratingException}
|
||||
|]
|
||||
] . fmap Just
|
||||
where
|
||||
ratingExceptionWidget = \case
|
||||
RatingFileIsDirectory -> i18n MsgRatingFileIsDirectory
|
||||
RatingSubmissionIDIncorrect -> i18n MsgRatingSubmissionIDIncorrect
|
||||
RatingValidityException exc -> i18n exc
|
||||
RatingParseException pExc
|
||||
-> [whamlet|
|
||||
$newline never
|
||||
_{MsgRatingParseException}
|
||||
<br>
|
||||
$case pExc
|
||||
$of RatingYAMLStreamTerminatedUnexpectedly
|
||||
_{MsgRatingYAMLStreamTerminatedUnexpectedly}
|
||||
$of RatingYAMLDocumentEndIllDefined
|
||||
_{MsgRatingYAMLDocumentEndIllDefined}
|
||||
$of RatingYAMLExceptionBeforeComment errStr
|
||||
_{MsgRatingYAMLExceptionBeforeComment}
|
||||
<br>
|
||||
<code .literal-error>
|
||||
#{errStr}
|
||||
$of RatingYAMLException errStr
|
||||
_{MsgRatingYAMLException}
|
||||
<br>
|
||||
<code .literal-error>
|
||||
#{errStr}
|
||||
$of RatingYAMLCommentNotUnicode unicodeErr
|
||||
_{MsgRatingYAMLCommentNotUnicode}
|
||||
<br>
|
||||
<code .literal-error>
|
||||
#{tshow unicodeErr}
|
||||
|]
|
||||
RatingParseLegacyException pExc
|
||||
-> [whamlet|
|
||||
$newline never
|
||||
_{MsgRatingParseLegacyException}
|
||||
<br>
|
||||
$case pExc
|
||||
$of RatingMissingSeparator
|
||||
_{MsgRatingMissingSeparator}
|
||||
$of RatingMultiple
|
||||
_{MsgRatingMultiple}
|
||||
$of RatingInvalid errStr
|
||||
_{MsgRatingInvalid}
|
||||
<br>
|
||||
<code .literal-error>
|
||||
#{errStr}
|
||||
$of RatingNotUnicode unicodeErr
|
||||
_{MsgRatingNotUnicode}
|
||||
<br>
|
||||
<code .literal-error>
|
||||
#{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 }
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user