233 lines
12 KiB
Haskell
233 lines
12 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- 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
|