diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 3a21c6d4d..6555ea5a3 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -691,6 +691,7 @@ RatingMissingSeparator: Präambel der Bewertungsdatei konnte nicht identifziert RatingMultiple: Bewertungen enthält mehrere Punktzahlen für die gleiche Abgabe RatingInvalid parseErr@Text: Bewertungspunktzahl konnte nicht als Zahl verstanden werden: #{parseErr} RatingFileIsDirectory: Bewertungsdatei ist unerlaubterweise ein Verzeichnis +RatingParseLegacyException renderedLegacyException@Text: Beim Interpretieren als Bewertungsdatei im veralteten Format: #{renderedLegacyException} RatingNegative: Bewertungspunkte dürfen nicht negativ sein RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt @@ -2616,4 +2617,11 @@ TestDownloadFromDatabase: Generierung während Download aus Datenbank ValueRequiredLabeledSimple fieldLabel@Text: #{fieldLabel} wird benötigt ValueRequiredLabeledMultiWord fieldLabel@Text: „#{fieldLabel}“ wird benötigt -RatingFileTitle subId@CryptoFileNameSubmission: bewertung_#{toPathPiece subId}.txt \ No newline at end of file +RatingFileTitle subId@CryptoFileNameSubmission: bewertung_#{toPathPiece subId}.txt + +RatingYAMLMetaComment: Meta-Informationen zur Korrektur (werden beim Hochladen ignoriert) +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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 54a6c5340..03bae360f 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -688,6 +688,7 @@ 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} RatingFileIsDirectory: Marking file must not be a directory +RatingParseLegacyException renderedLegacyException: While parsing as a rating file in legacy format: #{renderedLegacyException} RatingNegative: Marking points may not be negative RatingExceedsMax: Marking points exceed maximum RatingNotExpected: No marking points expected for this sheet @@ -2617,3 +2618,10 @@ ValueRequiredLabeledSimple fieldLabel: #{fieldLabel} is required ValueRequiredLabeledMultiWord fieldLabel: “#{fieldLabel}” is required RatingFileTitle subId: rating_#{toPathPiece subId}.txt + +RatingYAMLMetaComment: Metadata about correction (ignored during upload) +RatingYAMLRatingComment: Rating +RatingYAMLChangePointsComment: TODO: Insert number of points instead of null (up to two decimal places, use period as a decimal separator; e.g. 17.03) +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 (...) diff --git a/package.yaml b/package.yaml index 652846d88..d4f666947 100644 --- a/package.yaml +++ b/package.yaml @@ -147,6 +147,8 @@ dependencies: - async - pointedlist - clock + - HsYAML + - HsYAML-aeson other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Foundation.hs b/src/Foundation.hs index 924e9a0a4..f463eed7b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -251,6 +251,9 @@ newtype ShortWeekDay = ShortWeekDay { longWeekDay :: WeekDay } instance RenderMessage UniWorX ShortWeekDay where renderMessage _ ls (ShortWeekDay wDay) = pack . snd $ wDays (getTimeLocale' ls) !! (fromEnum wDay `mod` 7) +instance Default DateTimeFormatter where + def = mkDateTimeFormatter (getTimeLocale' []) def appTZ + -- Access Control newtype InvalidAuthTag = InvalidAuthTag Text diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index ea64b773e..3ed07be08 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -182,7 +182,6 @@ embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType id embedRenderMessage ''UniWorX ''SubmissionFileType id embedRenderMessage ''UniWorX ''CorrectorState id -embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel @@ -213,6 +212,18 @@ instance RenderMessage UniWorX RatingFileException 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 + newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Handler/Submission/Correction.hs b/src/Handler/Submission/Correction.hs index 607642eaf..5b7bd6877 100644 --- a/src/Handler/Submission/Correction.hs +++ b/src/Handler/Submission/Correction.hs @@ -76,6 +76,7 @@ postCorrectionR tid ssh csh shn cid = do { ratingPoints = ratingPoints' , ratingComment = ratingComment' , ratingTime = guardOn rated now + , ratingDone = rated } guardValidation MsgSubmissionCannotBeRatedWithoutCorrector $ isn't _Nothing ratingBy' || not rated diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 419788526..c800b8857 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -10,6 +10,7 @@ module Handler.Utils.DateTime , formatTime, formatTimeW, formatTimeMail , formatTimeRange, formatTimeRangeW, formatTimeRangeMail , getTimeLocale, getDateTimeFormat + , getDateTimeFormatter , validDateTimeFormats, dateTimeFormatOptions , addOneWeek, addWeeks , weeksToAdd @@ -23,15 +24,11 @@ import Import import Data.Time.Zones import qualified Data.Time.Zones as TZ -import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime, utcToZonedTime) --- import Data.Time.Clock (addUTCTime,nominalDay) import qualified Data.Time.Format as Time import Data.Time.Format.ISO8601 (iso8601Show) import qualified Data.Set as Set -import Data.Time.Clock.System (systemEpochDay) - import qualified Data.Csv as Csv import qualified Data.Char as Char @@ -69,22 +66,9 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} - -class FormatTime t => HasLocalTime t where - toLocalTime :: t -> LocalTime - -instance HasLocalTime LocalTime where - toLocalTime = id - -instance HasLocalTime Day where - toLocalTime d = LocalTime d midnight - instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime -instance HasLocalTime TimeOfDay where - toLocalTime = LocalTime systemEpochDay - formatTime' :: (HasLocalTime t, MonadHandler m) => String -> t -> m Text formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (utcToZonedTime . localTimeToUTCTZ appTZ $ toLocalTime t) @@ -123,6 +107,12 @@ getDateTimeFormat sel = do SelFormatTime -> userDefaultTimeFormat return fmt +getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormatter +getDateTimeFormatter = do + locale <- getTimeLocale + formatMap <- traverse getDateTimeFormat id + return $ mkDateTimeFormatter locale formatMap appTZ + validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat -- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon validDateTimeFormats tl SelFormatDateTime = Set.fromList $ diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 16b82dc03..7871adec8 100644 --- a/src/Handler/Utils/Rating.hs +++ b/src/Handler/Utils/Rating.hs @@ -3,8 +3,6 @@ module Handler.Utils.Rating , validateRating , getRating , ratingFile - , RatingException(..) - , UnicodeException(..) , isRatingFile , SubmissionContent , extractRatings @@ -13,6 +11,8 @@ module Handler.Utils.Rating import Import +import Handler.Utils.DateTime (getDateTimeFormatter) + import qualified Data.Text as Text import qualified Data.ByteString.Lazy as Lazy.ByteString @@ -42,14 +42,15 @@ validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. } validateRating ratingSheetType Rating'{ .. } | has _grading ratingSheetType , is _Nothing ratingPoints - , isn't _Nothing ratingTime + , ratingDone , hasn't (_grading . _PassAlways) ratingSheetType = [RatingPointsRequired] validateRating _ _ = [] getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating) getRating submissionId = runMaybeT $ do - let query = E.select . E.from $ \(corrector `E.RightOuterJoin` (submission `E.InnerJoin` sheet `E.InnerJoin` course)) -> do + let query = E.select . E.from $ \(corrector `E.RightOuterJoin` (submission `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` school)) -> do + E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy @@ -57,24 +58,29 @@ getRating submissionId = runMaybeT $ do E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId -- Yes, we can only pass a tuple through 'E.select' - return ( course E.^. CourseName + return ( course E.^. CourseTerm + , school E.^. SchoolName + , course E.^. CourseName , sheet E.^. SheetName , corrector E.?. UserDisplayName , sheet E.^. SheetType - , submission E.^. SubmissionRatingPoints - , submission E.^. SubmissionRatingComment - , submission E.^. SubmissionRatingTime + , submission ) - [ ( E.unValue -> ratingCourseName + [ ( unTermKey . E.unValue -> ratingCourseTerm + , E.unValue -> ratingCourseSchool + , E.unValue -> ratingCourseName , E.unValue -> ratingSheetName , E.unValue -> ratingCorrectorName , E.unValue -> ratingSheetType - , E.unValue -> ratingPoints - , E.unValue -> ratingComment - , E.unValue -> ratingTime + , E.Entity _ sub@Submission{..} ) ] <- lift query + let ratingPoints = submissionRatingPoints + ratingComment = submissionRatingComment + ratingTime = submissionRatingTime + ratingDone = submissionRatingDone sub + return Rating{ ratingValues = Rating'{..}, .. } extensionRating :: String @@ -85,11 +91,12 @@ ratingFile :: ( MonadHandler m ) => CryptoFileNameSubmission -> Rating -> m File ratingFile cID rating@Rating{ ratingValues = Rating'{..}, .. } = do - MsgRenderer mr <- getMsgRenderer + mr'@(MsgRenderer mr) <- getMsgRenderer + dtFmt <- getDateTimeFormatter fileModified <- maybe (liftIO getCurrentTime) return ratingTime let fileTitle = ensureExtension extensionRating . unpack . mr $ MsgRatingFileTitle cID - fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating + fileContent = Just . Lazy.ByteString.toStrict $ formatRating mr' dtFmt cID rating return File{..} where ensureExtension ext fName = bool (`addExtension` ext) id (ext `isExtensionOf` fName) fName diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs index 8235cbc2f..f7bcddf98 100644 --- a/src/Handler/Utils/Rating/Format.hs +++ b/src/Handler/Utils/Rating/Format.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS -Wno-error=deprecations #-} module Handler.Utils.Rating.Format ( parseRating, formatRating @@ -6,81 +6,162 @@ module Handler.Utils.Rating.Format import Import -import Text.PrettyPrint.Leijen.Text hiding ((<$>)) -import Text.Read (readEither) +import Handler.Utils.DateTime () + +import qualified Data.Map.Strict as Map + +import qualified Data.Char as Char import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text +import qualified Data.Text.Lazy as Lazy.Text import qualified Data.Text.Lazy.Encoding as Lazy.Text import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.CaseInsensitive as CI -instance HasResolution prec => Pretty (Fixed prec) where - pretty = pretty . show +import qualified Handler.Utils.Rating.Format.Legacy as Legacy -instance Pretty x => Pretty (CI x) where - pretty = pretty . CI.original +import qualified Data.YAML as YAML +import qualified Data.YAML.Event as YAML (untagged) +import qualified Data.YAML.Event as YAML.Event +import qualified Data.YAML.Token as YAML (Encoding(..)) +import Data.YAML.Aeson () -- ToYAML Value + +import Data.List (elemIndex) + +import Control.Monad.Trans.State.Lazy (evalState) -instance Pretty SheetGrading where - pretty Points{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e)" :: String) - pretty PassPoints{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e), bestanden ab " <> show passingPoints <> " Punkt(en)" :: String ) - pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) - pretty PassAlways = pretty ( "Automatisch bestanden, sobald korrigiert" :: String ) +data PrettifyState + = PrettifyInitial + | PrettifyMetadata Natural + | PrettifyRatingPoints + | PrettifyRatingPassed + | PrettifyRating + | PrettifyRatingDone + | PrettifyComment + deriving (Eq, Ord, Read, Show, Generic, Typeable) - -formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString -formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let - doc = renderPretty 1 45 . foldr (<$$>) mempty $ catMaybes - [ pure "= Bitte nur Bewertung und Kommentare ändern =" - , pure "=============================================" - , pure "========== Uni2work Bewertungsdatei =========" - , pure "======= diese Datei ist UTF8 encodiert ======" - , pure "Informationen zum Übungsblatt:" - , pure . indent 2 . foldr (<$$>) mempty . catMaybes $ - [ Just $ "Veranstaltung:" <+> pretty ratingCourseName - , Just $ "Blatt:" <+> pretty ratingSheetName - , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName - , ("Bewertungsschema:" <+>) . pretty <$> (ratingSheetType ^? _grading) + +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 + ] + where + uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat + [ [ YAML.Event.StreamStart + , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2 + ] + , concat + [ pure $ YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block + , mapEvents (str' "term") (msg $ ShortTermIdentifier ratingCourseTerm) + , mapEvents (str' "school") (str $ CI.original ratingCourseSchool) + , mapEvents (str' "course") (str $ CI.original ratingCourseName) + , nodeEvents (str' "sheet") + , case YAML.toYAML $ toJSON ratingSheetType of + YAML.Mapping _ _ typeMap + -> let typeMap' = flip sortOn (Map.toList typeMap) $ \case + (YAML.Scalar _ (YAML.SStr k), _) -> NTop $ k `elemIndex` ["type", "grading"] + _other -> NTop Nothing + in concat + [ pure $ YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block + , mapEvents (str' "name") (str $ CI.original ratingSheetName) + , concat [ mapEvents k v | (k, v) <- typeMap' ] + , 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) + , case ratingSheetType ^? _grading of + Nothing -> mempty + Just mode -> if + | is _PassAlways mode + -> mempty + | has _passingBound 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) + , mapEvents (str' "rating_done") (YAML.Scalar () $ YAML.SBool ratingDone) + , pure $ YAML.Event.MappingEnd + ] + , [ YAML.Event.DocumentEnd True + , YAML.Event.StreamEnd + ] ] - , pure $ "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) - , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) "=============================================" - , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) $ "Bewertung:" <+> pretty ratingPoints - , pure "=========== Beginn der Kommentare ===========" - , pure $ pretty ratingComment - ] - in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc + where str :: forall t. Textual t => t -> YAML.Node () + str = YAML.Scalar () . YAML.SStr . repack + str' :: Text -> YAML.Node () + str' = str + msg :: forall msg. RenderMessage UniWorX msg => msg -> YAML.Node () + msg = str . mr -parseRating :: MonadThrow m => File -> m Rating' -parseRating File{ fileContent = Just input, .. } = do - inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input - let - (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText - (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' - ratingLines' = filter (rating `Text.isInfixOf`) ratingLines - commentSep :: Text - commentSep = "Beginn der Kommentare" - sep' = Text.pack $ replicate 40 '=' - rating :: Text - rating = "Bewertung:" - comment' <- case commentLines of - (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' - _ -> throwM RatingMissingSeparator - let - ratingComment - | Text.null comment' = Nothing - | otherwise = Just comment' - ratingLine' <- case ratingLines' of - [] -> return Text.empty - [l] -> return l - _ -> throwM RatingMultiple - let - (_, ratingLine) = Text.breakOnEnd rating ratingLine' - ratingStr = Text.unpack $ Text.strip ratingLine - ratingPoints <- case () of - _ | null ratingStr -> return Nothing - | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr - return Rating'{ ratingTime = Just fileModified, .. } -parseRating _ = throwM RatingFileIsDirectory + mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event] + mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v + where filterEvs ((YAML.Event.MappingStart _ _ _ : inner) :> YAML.Event.MappingEnd) = inner + filterEvs _other = error "Could not strip Mapping" + + nodeEvents :: YAML.Node () -> [YAML.Event.Event] + nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc + where filterEvs = filter $ \case + YAML.Event.StreamStart -> False + YAML.Event.StreamEnd -> False + YAML.Event.DocumentStart _ -> False + YAML.Event.DocumentEnd _ -> False + _other -> True + + prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML + where + transduce' (Left _ : _) = error "Parse error on uglyYAML" + transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _)) + = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (flip transduce eEvent)) <*> transduce' es + transduce' (Right YAML.Event.EvPos{..} : es@_) + = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (flip transduce eEvent)) <*> transduce' es + transduce' [] = return [] + + annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse + where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann2)) + = let (before', after) = Lazy.ByteString.splitAt pos2' dat + (before, event) = Lazy.ByteString.splitAt pos1' before' + event' = decodeUtf8 $ toStrict event + ws = Text.takeWhileEnd Char.isSpace event' + event'' = Text.dropWhileEnd Char.isSpace event' + pos1' = min pos1 mLength + pos2' = min pos2 mLength + in (before <> ann1 <> fromStrict (encodeUtf8 event'') <> fromStrict (encodeUtf8 $ ann2 ws) <> after, pos1') + + transduce :: PrettifyState -> YAML.Event.Event -> ((Text, Text -> Text), PrettifyState) + 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" + 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 PrettifyRatingPoints _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePointsComment), PrettifyRating) + transduce PrettifyRatingPassed _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangePassedComment), PrettifyRating) + transduce PrettifyRatingDone _ = ((mempty, beforeBreak $ " # " <> mr MsgRatingYAMLChangeDoneComment), PrettifyRating) + transduce PrettifyRating (YAML.Event.Scalar _ _ _ k) + | k == "points" = ((mempty, id), PrettifyRatingPoints) + | k == "passed" = ((mempty, id), PrettifyRatingPassed) + | k == "rating_done" = ((mempty, id), PrettifyRatingDone) + transduce PrettifyRating YAML.Event.MappingEnd = (("\n", (<> ("# " <> mr MsgRatingYAMLChangeCommentComment <> "\n"))), PrettifyComment) + transduce PrettifyRating _ = ((mempty, id), PrettifyRating) + transduce PrettifyComment _ = ((mempty, id), PrettifyComment) + -- transduce cState _ = (("<", \ws -> "|" <> ws <> ">"), cState) -- TODO + + beforeBreak :: Text -> Text -> Text + beforeBreak ins ws = before <> ins <> break' <> after + where (before', after) = Text.breakOnEnd "\n" ws + before = Text.dropWhileEnd (== '\n') before' + break' = Text.takeWhileEnd (== '\n') before' + +parseRating :: MonadCatch m => File -> m Rating' +parseRating = Legacy.parseRating diff --git a/src/Handler/Utils/Rating/Format/Legacy.hs b/src/Handler/Utils/Rating/Format/Legacy.hs new file mode 100644 index 000000000..0bfa93af1 --- /dev/null +++ b/src/Handler/Utils/Rating/Format/Legacy.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Utils.Rating.Format.Legacy + ( parseRating, formatRating + ) where + +import Import + +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +import qualified Data.Text as Text +import qualified Data.Text.Lazy.Encoding as Lazy.Text +import qualified Data.Text.Encoding as Text + +import qualified Data.ByteString.Lazy as Lazy (ByteString) + +import qualified Data.CaseInsensitive as CI + + +import Text.Read (readEither) + +instance HasResolution prec => Pretty (Fixed prec) where + pretty = pretty . show + +instance Pretty x => Pretty (CI x) where + pretty = pretty . CI.original + + +instance Pretty SheetGrading where + pretty Points{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e)" :: String) + pretty PassPoints{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e), bestanden ab " <> show passingPoints <> " Punkt(en)" :: String ) + pretty PassBinary = pretty ( "Bestanden (1) / Nicht bestanden (0)" :: String ) + pretty PassAlways = pretty ( "Automatisch bestanden, sobald korrigiert" :: String ) + + +formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString +formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let + doc = renderPretty 1 45 . foldr (<$$>) mempty $ catMaybes + [ pure "= Bitte nur Bewertung und Kommentare ändern =" + , pure "=============================================" + , pure "========== Uni2work Bewertungsdatei =========" + , pure "======= diese Datei ist UTF8 encodiert ======" + , pure "Informationen zum Übungsblatt:" + , pure . indent 2 . foldr (<$$>) mempty . catMaybes $ + [ Just $ "Veranstaltung:" <+> pretty ratingCourseName + , Just $ "Blatt:" <+> pretty ratingSheetName + , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName + , ("Bewertungsschema:" <+>) . pretty <$> (ratingSheetType ^? _grading) + ] + , pure $ "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID) + , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) "=============================================" + , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) $ "Bewertung:" <+> pretty ratingPoints + , pure "=========== Beginn der Kommentare ===========" + , pure $ pretty ratingComment + ] + in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc + +parseRating :: MonadCatch m => File -> m Rating' +parseRating File{ fileContent = Just input, .. } = handle (throwM . RatingParseLegacyException) $ do + inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input + let + (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText + (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines' + ratingLines' = filter (rating `Text.isInfixOf`) ratingLines + commentSep :: Text + commentSep = "Beginn der Kommentare" + sep' = Text.pack $ replicate 40 '=' + rating :: Text + rating = "Bewertung:" + comment' <- case commentLines of + (_:commentLines') -> return . Text.strip $ Text.unlines commentLines' + _ -> throwM RatingMissingSeparator + let + ratingComment + | Text.null comment' = Nothing + | otherwise = Just comment' + ratingLine' <- case ratingLines' of + [] -> return Text.empty + [l] -> return l + _ -> throwM RatingMultiple + let + (_, ratingLine) = Text.breakOnEnd rating ratingLine' + ratingStr = Text.unpack $ Text.strip ratingLine + ratingPoints <- case () of + _ | null ratingStr -> return Nothing + | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr + return Rating'{ ratingDone = False, ratingTime = Just fileModified, .. } +parseRating _ = throwM RatingFileIsDirectory diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 62788038c..4fe283fd6 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -563,8 +563,8 @@ sinkSubmission userId mExists isUpdate = do submission <- lift $ getJust submissionId now <- liftIO getCurrentTime + let rated = ratingDone r let - rated = fromMaybe False $ (==) <$> submissionRatingBy submission <*> userId -- FIXME: This behaviour is unintuitive and needs to be replaced with an "isDone"-Field in rating files r'@Rating'{..} = r { ratingTime = now <$ guard rated -- Ignore `ratingTime` from result @r@ of `parseRating` to ensure plausible timestamps (`parseRating` returns file modification time for consistency with `ratingFile`) } @@ -572,7 +572,7 @@ sinkSubmission userId mExists isUpdate = do { submissionRatingPoints = ratingPoints , submissionRatingComment = ratingComment , submissionRatingTime = ratingTime - , submissionRatingBy = userId <* guard rated -- This is never an update due to the definition of rated; this is done so idempotency of uploads is maintained (FIXME: when "isDone"-Field is introduced, set this to `Just userId`) + , submissionRatingBy = userId } tellSt $ mempty{ sinkSeenRating = Last $ Just r' } diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index 61e9591b2..fe7cf9ced 100644 --- a/src/Model/Rating.hs +++ b/src/Model/Rating.hs @@ -8,7 +8,9 @@ import Data.Text.Encoding.Error (UnicodeException(..)) data Rating = Rating - { ratingCourseName :: CourseName + { ratingCourseTerm :: TermIdentifier + , ratingCourseSchool :: SchoolName + , ratingCourseName :: CourseName , ratingSheetName :: SheetName , ratingCorrectorName :: Maybe Text , ratingSheetType :: SheetType @@ -19,18 +21,25 @@ data Rating' = Rating' { ratingPoints :: Maybe Points , ratingComment :: Maybe Text , ratingTime :: Maybe UTCTime + , ratingDone :: Bool } 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 Text -- ^ 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 - | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points +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 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 deriving (Show, Eq, Generic, Typeable) deriving anyclass (Exception) diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 29861dfc8..9b2ed78d6 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -4,20 +4,26 @@ module Utils.DateTime ( timeLocaleMap , TimeLocale(..) , currentYear + , HasLocalTime(..) , DateTimeFormat(..) , SelDateTimeFormat(..) + , DateTimeFormatter(..) + , mkDateTimeFormatter , nominalHour, nominalMinute , minNominalYear, avgNominalYear - , module Data.Time.Zones - , module Data.Time.Zones.TH + , module Zones ) where import ClassyPrelude.Yesod hiding (lift) import System.Locale.Read -import Data.Time (NominalDiffTime, nominalDay) -import Data.Time.Zones (TZ) -import Data.Time.Zones.TH (includeSystemTZ) +import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..)) +import Data.Time.Zones as Zones (TZ) +import Data.Time.Zones.TH as Zones (includeSystemTZ) +import Data.Time.Zones (localTimeToUTCTZ, timeZoneForUTCTime) +import Data.Time.Format (FormatTime) +import Data.Time.Clock.System (systemEpochDay) +import qualified Data.Time.Format as Time import qualified Data.List.NonEmpty as NonEmpty @@ -72,6 +78,17 @@ currentYear = do let (year, _, _) = toGregorian $ utctDay now [e|year|] +class FormatTime t => HasLocalTime t where + toLocalTime :: t -> LocalTime + +instance HasLocalTime LocalTime where + toLocalTime = id + +instance HasLocalTime Day where + toLocalTime d = LocalTime d midnight + +instance HasLocalTime TimeOfDay where + toLocalTime = LocalTime systemEpochDay newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) @@ -105,6 +122,10 @@ instance BoundedJoinSemiLattice SelDateTimeFormat where instance BoundedMeetSemiLattice SelDateTimeFormat where top = SelFormatDateTime +data DateTimeFormatter = DateTimeFormatter { format :: forall t. HasLocalTime t => SelDateTimeFormat -> t -> Text } + +mkDateTimeFormatter :: TimeLocale -> (SelDateTimeFormat -> DateTimeFormat) -> TZ -> DateTimeFormatter +mkDateTimeFormatter locale formatMap appTZ = DateTimeFormatter (\(formatMap -> fmt) t -> pack . Time.formatTime locale (unDateTimeFormat fmt) $ ZonedTime (toLocalTime t) (timeZoneForUTCTime appTZ . localTimeToUTCTZ appTZ $ toLocalTime t)) --------------------- -- NominalDiffTime -- diff --git a/test/Handler/Utils/RatingSpec.hs b/test/Handler/Utils/RatingSpec.hs index feaadd458..c3e15031c 100644 --- a/test/Handler/Utils/RatingSpec.hs +++ b/test/Handler/Utils/RatingSpec.hs @@ -10,18 +10,22 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text -import Utils (assertM) +import Utils (assertM, MsgRendererS(..)) +import Text.Shakespeare.I18N (renderMessage) spec :: Spec spec = describe "Rating file parsing/pretty-printing" $ do it "roundtrips" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) -> - parseRating' (formatRating subId rating) === Just (ratingValues rating) + parseRating' (formatRating mr' def subId rating) === Just (ratingValues rating) it "has idempotent formatting" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) -> - fmap (\r' -> formatRating subId $ rating { ratingValues = r' }) (parseRating' $ formatRating subId rating) === Just (formatRating subId rating) + fmap (\r' -> formatRating mr' def subId $ rating { ratingValues = r' }) (parseRating' $ formatRating mr' def subId rating) === Just (formatRating mr' def subId rating) where + mr' :: forall site. MsgRendererS site + mr' = MsgRenderer $ renderMessage (error "foundation inspected" :: site) [] + parseRating' :: LBS.ByteString -> Maybe Rating' - parseRating' = parseRating . flip (File "bewertung.txt") time . Just . LBS.toStrict + 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 }