feat(rating): pretty-print to new yaml based format

Parsing not implemented yet; tests should fail

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
+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

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 (...)

package.yaml

@@ -147,6 +147,8 @@ dependencies:
   - async
   - pointedlist
   - clock
+  - HsYAML
+  - HsYAML-aeson
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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

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" <>)
 

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
 

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 $

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
-               , submission E.^. SubmissionRatingComment
-               , submission E.^. SubmissionRatingTime
                )
 
-  [ ( 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.Entity _ sub@Submission{..}
-    , E.unValue -> ratingComment
-    , E.unValue -> ratingTime
     ) ] <- 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
 

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 Handler.Utils.DateTime ()
-import Text.Read (readEither)
+
+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
+import qualified Handler.Utils.Rating.Format.Legacy as Legacy
-  pretty = pretty . show
 
-instance Pretty x => Pretty (CI x) where
+import qualified Data.YAML as YAML
-  pretty = pretty . CI.original
+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
+data PrettifyState
-  pretty Points{..}     = pretty ( "Maximal " <> show maxPoints <> " Punkt(e)" :: String)
+  = PrettifyInitial
-  pretty PassPoints{..} = pretty ( "Maximal " <> show maxPoints <> " Punkt(e), bestanden ab " <> show passingPoints <> " Punkt(en)" :: String )
+  | PrettifyMetadata Natural
-  pretty PassBinary     = pretty ( "Bestanden (1) /  Nicht bestanden (0)" :: String )
+  | PrettifyRatingPoints
-  pretty PassAlways     = pretty ( "Automatisch bestanden, sobald korrigiert" :: String )
+  | PrettifyRatingPassed
+  | PrettifyRating
+  | PrettifyRatingDone
+  | PrettifyComment
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
-
+  
-formatRating :: CryptoFileNameSubmission -> Rating -> Lazy.ByteString
+formatRating :: MsgRendererS UniWorX -> DateTimeFormatter -> CryptoFileNameSubmission -> Rating -> Lazy.ByteString
-formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
+formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = Rating'{..}, .. } = mconcat
-  doc = renderPretty 1 45 . foldr (<$$>) mempty $ catMaybes
+  [ prettyYAML
-    [ pure "= Bitte nur Bewertung und Kommentare ändern ="
+  , maybe Lazy.ByteString.empty (Lazy.Text.encodeUtf8 . Lazy.Text.fromStrict) ratingComment
-    , pure "============================================="
+  ]
-    , pure "========== Uni2work Bewertungsdatei ========="
+  where
-    , pure "======= diese Datei ist UTF8 encodiert ======"
+    uglyYAML = YAML.Event.writeEvents YAML.UTF8 $ concat
-    , pure "Informationen zum Übungsblatt:"
+      [ [ YAML.Event.StreamStart
-    , pure . indent 2 . foldr (<$$>) mempty . catMaybes $
+        , YAML.Event.DocumentStart $ YAML.Event.DirEndMarkerVersion 2
-      [ Just $ "Veranstaltung:" <+> pretty ratingCourseName
+        ]
-      , Just $ "Blatt:" <+> pretty ratingSheetName
+      , concat
-      , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
+        [ pure $ YAML.Event.MappingStart Nothing YAML.untagged YAML.Event.Block
-      , ("Bewertungsschema:" <+>) . pretty <$> (ratingSheetType ^? _grading)
+        , 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)
+      where str :: forall t. Textual t => t -> YAML.Node ()
-    , guardOn (hasn't (_grading . _PassAlways) ratingSheetType)   "============================================="
+            str = YAML.Scalar () . YAML.SStr . repack
-    , guardOn (hasn't (_grading . _PassAlways) ratingSheetType) $ "Bewertung:" <+> pretty ratingPoints
+            str' :: Text -> YAML.Node ()
-    , pure   "=========== Beginn der Kommentare ==========="
+            str' = str
-    , pure $ pretty ratingComment
+            msg :: forall msg. RenderMessage UniWorX msg => msg -> YAML.Node ()
-    ]
+            msg = str . mr
-  in Lazy.Text.encodeUtf8 . (<> "\n") $ displayT doc
 
-parseRating :: MonadThrow m => File -> m Rating'
+            mapEvents :: YAML.Node () -> YAML.Node () -> [YAML.Event.Event]
-parseRating File{ fileContent = Just input, .. } = do
+            mapEvents k v = filterEvs . nodeEvents . YAML.Mapping () YAML.untagged $ singletonMap k v
-  inputText <- either (throwM . RatingNotUnicode) return $ Text.decodeUtf8' input
+              where filterEvs ((YAML.Event.MappingStart _ _ _ : inner) :> YAML.Event.MappingEnd) = inner
-  let
+                    filterEvs _other = error "Could not strip Mapping"
-    (headerLines', commentLines) = break (commentSep `Text.isInfixOf`) $ Text.lines inputText
+
-    (reverse -> ratingLines, reverse -> _headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
+            nodeEvents :: YAML.Node () -> [YAML.Event.Event]
-    ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
+            nodeEvents = filterEvs . mapMaybe (fmap YAML.Event.eEvent . preview _Right) . YAML.Event.parseEvents . YAML.encodeNode . pure . YAML.Doc
-    commentSep :: Text
+              where filterEvs = filter $ \case
-    commentSep = "Beginn der Kommentare"
+                      YAML.Event.StreamStart -> False
-    sep' = Text.pack $ replicate 40 '='
+                      YAML.Event.StreamEnd -> False
-    rating :: Text
+                      YAML.Event.DocumentStart _ -> False
-    rating = "Bewertung:"
+                      YAML.Event.DocumentEnd _ -> False
-  comment' <- case commentLines of
+                      _other -> True
-    (_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
+
-    _ -> throwM RatingMissingSeparator
+    prettyYAML = annotate . (evalState ?? PrettifyInitial) . transduce' $ YAML.Event.parseEvents uglyYAML
-  let
+      where
-    ratingComment
+        transduce' (Left _ : _) = error "Parse error on uglyYAML"
-      | Text.null comment' = Nothing
+        transduce' (Right YAML.Event.EvPos{ eEvent, ePos = pos1 } : es@(Right YAML.Event.EvPos{ ePos = pos2 }: _))
-      | otherwise = Just comment'
+          = (:) <$> ((YAML.Event.posByteOffset pos1, YAML.Event.posByteOffset pos2, ) <$> state (flip transduce eEvent)) <*> transduce' es
-  ratingLine' <- case ratingLines' of
+        transduce' (Right YAML.Event.EvPos{..} : es@_)
-    [] -> return Text.empty
+          = (:) <$> ((YAML.Event.posByteOffset ePos, fromIntegral $ Lazy.ByteString.length uglyYAML, ) <$> state (flip transduce eEvent)) <*> transduce' es
-    [l] -> return l
+        transduce' [] = return []
-    _ -> throwM RatingMultiple
+
-  let
+        annotate = fst . foldl' annotate' (uglyYAML, Lazy.ByteString.length uglyYAML) . reverse
-    (_, ratingLine) = Text.breakOnEnd rating ratingLine'
+          where annotate' (dat, mLength) (fromIntegral -> pos1, fromIntegral -> pos2, (fromStrict . encodeUtf8 -> ann1, ann2))
-    ratingStr = Text.unpack $ Text.strip ratingLine
+                  = let (before', after) = Lazy.ByteString.splitAt pos2' dat
-  ratingPoints <- case () of
+                        (before, event) = Lazy.ByteString.splitAt pos1' before'
-    _ | null ratingStr -> return Nothing
+                        event' = decodeUtf8 $ toStrict event
-      | otherwise -> either (throwM . RatingInvalid . pack) return $ Just <$> readEither ratingStr
+                        ws = Text.takeWhileEnd Char.isSpace event'
-  return Rating'{ ratingTime = Just fileModified, .. }
+                        event'' = Text.dropWhileEnd Char.isSpace event'
-parseRating _ = throwM RatingFileIsDirectory
+                        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

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

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' }
 

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
+data RatingParseLegacyException
-                     | RatingMissingSeparator -- ^ Could not split rating header from comments
+  = RatingNotUnicode UnicodeException -- ^ Rating failed to parse as unicode
-                     | RatingMultiple -- ^ Encountered multiple point values in rating
+  | RatingMissingSeparator            -- ^ Could not split rating header from comments
-                     | RatingInvalid Text -- ^ Failed to parse rating point value
+  | RatingMultiple                    -- ^ Encountered multiple point values in rating
-                     | RatingFileIsDirectory -- ^ We do not expect this to, it's included for totality
+  | RatingInvalid Text                -- ^ Failed to parse rating point value
-                     | RatingNegative -- ^ Rating points must be non-negative
+  | RatingFileIsDirectory             -- ^ We do not expect this to, it's included for totality
-                     | RatingExceedsMax -- ^ Rating point must not exceed maximum points
+  deriving (Show, Eq, Generic, Typeable)
-                     | RatingNotExpected -- ^ Rating not expected
+  deriving anyclass (Exception)
-                     | RatingBinaryExpected -- ^ Rating must be 0 or 1
+
-                     | RatingPointsRequired -- ^ Rating without points for sheet that requires there to be points
+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)
 

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 Zones
-  , module Data.Time.Zones.TH
   ) where
 
 import ClassyPrelude.Yesod hiding (lift)
 import System.Locale.Read
 
-import Data.Time (NominalDiffTime, nominalDay)
+import Data.Time (NominalDiffTime, nominalDay, LocalTime(..), TimeOfDay, midnight, ZonedTime(..))
-import Data.Time.Zones (TZ)
+import Data.Time.Zones as Zones (TZ)
-import Data.Time.Zones.TH (includeSystemTZ)
+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 --

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 }