feat(rating): pretty-print to new yaml based format
Parsing not implemented yet; tests should fail
This commit is contained in:
Gregor Kleen
parent
1195231bc3
commit
2bf484609e
@ -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
|
||||
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
|
||||
@ -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 (...)
|
||||
|
||||
@ -147,6 +147,8 @@ dependencies:
|
||||
- async
|
||||
- pointedlist
|
||||
- clock
|
||||
- HsYAML
|
||||
- HsYAML-aeson
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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" <>)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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 $
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
88
src/Handler/Utils/Rating/Format/Legacy.hs
Normal file
88
src/Handler/Utils/Rating/Format/Legacy.hs
Normal file
@ -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
|
||||
@ -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' }
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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 }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user