-- SPDX-FileCopyrightText: 2022 Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS -fno-warn-orphans #-} module Handler.Utils.Rating.Format ( parseRating, formatRating ) where import Import 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.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 import qualified Handler.Utils.Rating.Format.Legacy as Legacy 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 Control.Monad.Trans.State.Lazy (evalState) import qualified System.FilePath.Cryptographic as Explicit import Control.Exception (ErrorCall(..)) import qualified Data.Conduit.Combinators as C data PrettifyState = PrettifyInitial | PrettifyMetadata Natural | PrettifySubmissionId | PrettifyRatingPoints | PrettifyRatingPassed | PrettifyRating | PrettifyRatingDone | PrettifyComment deriving (Eq, Ord, Read, Show, Generic) 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 . 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 ] , 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' "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 . _Left) mode -> mapEvents (str' "passed") (YAML.Scalar () . maybe YAML.SNull YAML.SBool $ gradingPassed mode =<< ratingPoints) | Just ratingPoints' <- ratingPoints ^? _Just . _Integer -> mapEvents (str' "points") (YAML.Scalar () $ YAML.SInt ratingPoints') | otherwise -> mapEvents (str' "points") (YAML.Scalar () $ maybe YAML.SNull (YAML.SFloat . realToFrac) ratingPoints) , mapEvents (str' "rating_done") (YAML.Scalar () $ YAML.SBool ratingDone) , pure YAML.Event.MappingEnd ] , [ YAML.Event.DocumentEnd True , YAML.Event.StreamEnd ] ] 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 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 (`transduce` eEvent)) <*> transduce' es transduce' (Right YAML.Event.EvPos{..} : es) = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (`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 == "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) 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' 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' <- asum [ fmap (fromIntegral :: Integer -> Points) <$> m YAML..:? "points" , 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 -> m (Rating', Maybe CryptoFileNameSubmission) parseRating f@File{ fileContent = Just input', .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do input <- runConduit $ input' .| C.sinkLazy 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 res <- case YAML.decode1 yamlInput of Left (pos, errStr) -> throwM . RatingYAMLException $ YAML.prettyPosWithSource pos yamlInput errStr Right cb -> return $ cb (Just fileModified) ratingComment return $!! res where onFailure (e :: RatingException) = ((, Nothing) <$> Legacy.parseRating f) `catch` \case RatingParseLegacyException _ -> throwM e other -> throwM other isYAMLUnicodeError (ErrorCall msg) = "UTF" `isPrefixOf` msg parseRating _ = throwM RatingFileIsDirectory