fix(ratings): improve decoding error reporting

config/mimetypes

@@ -736,6 +736,7 @@ text/vnd.in3d.spot spot
 text/vnd.sun.j2me.app-descriptor jad
 text/vnd.wap.wml wml
 text/vnd.wap.wmlscript wmls
+text/vnd.yaml yaml yml
 text/x-asm s asm
 text/x-c hh h dic cc
 text/x-component htc

frontend/src/utils/alerts/alerts.sass

@@ -98,10 +98,10 @@
   padding: 8px 0
   min-height: 40px
   position: relative
-  display: flex
   font-weight: 600
   align-items: center
   text-align: left
+  overflow: auto
 
 .alert__icon
   text-align: right

messages/uniworx/de-de-formal.msg

@@ -704,6 +704,7 @@ RatingSubmissionException smid@CryptoFileNameSubmission: Beim Verarbeiten der Be
 RatingYAMLExceptionBeforeComment: Beim Interpretieren des YAML-Teils (zum Abtrennen des Kommentars) ist folgender Fehler aufgetreten:
 RatingYAMLException: Beim Interpretieren des YAML-Teils ist folgender Fehler aufgetreten:
 RatingYAMLCommentNotUnicode: Der enthaltene Kommentar konnte nicht als UTF-8 dekodiert werden:
+RatingYAMLNotUnicode: Der enthaltene YAML-Teil konnte nicht als UTF-8 dekodiert werden:
 RatingYAMLStreamTerminatedUnexpectedly: Event-Stream unerwartet abgebrochen
 RatingYAMLDocumentEndIllDefined: Position des Endes des YAML-Teils nicht wohldefiniert
 RatingSubmissionIDIncorrect: Die in der Bewertungsdatei enthaltene Abgabenummer passt nicht zum Dateinamen

messages/uniworx/en-eu.msg

@@ -701,6 +701,7 @@ RatingSubmissionException smid: While processing the rating file for the submiss
 RatingYAMLExceptionBeforeComment: While parsing the YAML part (to separate out the rating comment) the following error occurred:
 RatingYAMLException: While parsing the YAML part the following error occurred:
 RatingYAMLCommentNotUnicode: The contained rating comment could not be UTF-8 decoded:
+RatingYAMLNotUnicode: The contained YAML part could not be decoded as UTF-8:
 RatingYAMLStreamTerminatedUnexpectedly: Event stream terminated unexpectedly
 RatingYAMLDocumentEndIllDefined: End of YAML part has no well defined position
 RatingSubmissionIDIncorrect: The submission id contained within the rating file does not match it's name

src/Handler/Utils/Rating.hs

@@ -26,6 +26,8 @@ import Handler.Utils.Rating.Format
 import qualified Data.Set as Set
 import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Char as Char
+
 
 validateRating :: SheetType -> Rating' -> [RatingValidityException]
 validateRating ratingSheetType Rating'{ ratingPoints=Just rp, .. }
@@ -104,6 +106,7 @@ type SubmissionContent = Either File (SubmissionId, Rating')
 
 extractRatings :: ( MonadHandler m
                   , HandlerSite m ~ UniWorX
+                  
                   ) => ConduitT File SubmissionContent m ()
 extractRatings = Conduit.mapM $ \f@File{..} -> liftHandler $ do
   msId <- isRatingFile fileTitle
@@ -121,13 +124,16 @@ isRatingFile :: forall m.
                 ( MonadHandler m
                 , HandlerSite m ~ UniWorX
                 ) => FilePath -> m (Maybe SubmissionId)
-isRatingFile fName = liftHandler $
+isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do
-  fmap getFirst . flip foldMapM segments' $ fmap First . tryDecrypt
+  app <- getYesod
+  (cID, subId) <- MaybeT . fmap getFirst . flip foldMapM segments' $ fmap First . tryDecrypt
+  guard $ isRatingFileName app cID
+  return subId
   where
-    tryDecrypt :: Text -> Handler (Maybe SubmissionId)
+    tryDecrypt :: Text -> Handler (Maybe (CryptoFileNameSubmission, SubmissionId))
     tryDecrypt ciphertext
       | Just cID <- fromPathPiece ciphertext
-      = (Just <$> decrypt (cID :: CryptoFileNameSubmission)) `catch` decryptErrors
+      = (Just . (cID, ) <$> decrypt cID) `catch` decryptErrors
       | otherwise
       = return Nothing
 
@@ -140,3 +146,19 @@ isRatingFile fName = liftHandler $
 
     cryptoIdChars :: Set (CI Char)
     cryptoIdChars = Set.fromList . map CI.mk $ "uwa" ++ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
+ 
+    isRatingFileName app cID = is _Just $ do
+      [CI.mk -> dWord, number, CI.mk -> extension] <- pure . filter (not . Text.null) . Text.split (not . Char.isAlphaNum) $ Text.pack fName
+      guard $ Text.all (flip Set.member cryptoIdChars . CI.mk) number
+      cID' <- fromPathPiece number
+      guard $ cID' == cID
+      let ratingTexts = map (flip (renderMessage app) (MsgRatingFileTitle cID) . pure) $ toList appLanguages
+          ratingWords = Set.fromList $ do
+            (pack . ensureExtension extensionRating . unpack -> ratingText) <- ratingTexts
+            (CI.mk -> dWord') : _ <- pure . filter (not . Text.null) . Text.split (not . Char.isAlphaNum) $ Text.pack ratingText
+            return dWord'
+      guard $ dWord `Set.member` ratingWords
+      let canonExtension = Set.singleton $ CI.mk (pack extensionRating)
+          validExtensions = foldMap (Set.map CI.mk . mimeExtensions) ["application/json", "text/vnd.yaml"]
+      guard $ extension `Set.member` Set.union canonExtension validExtensions
+      where ensureExtension ext fName' = bool (`addExtension` ext) id (ext `isExtensionOf` fName') fName'

src/Handler/Utils/Rating/Format.hs

@@ -35,6 +35,8 @@ import Control.Monad.Trans.State.Lazy (evalState)
 
 import qualified System.FilePath.Cryptographic as Explicit
 
+import Control.Exception (ErrorCall(..))
+
 
 data PrettifyState
   = PrettifyInitial
@@ -191,7 +193,7 @@ instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (May
   
   
 parseRating :: MonadCatch m => File -> m (Rating', Maybe CryptoFileNameSubmission)
-parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFailure . handle (throwM . RatingParseException) $ do
+parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFailure . handle (throwM . RatingParseException) . handleIf isYAMLUnicodeError (\(ErrorCall msg) -> throwM $ RatingYAMLNotUnicode msg) $ do
   let evStream = YAML.Event.parseEvents input
       delimitDocument = do
         ev <- maybe (throwM RatingYAMLStreamTerminatedUnexpectedly) return =<< await
@@ -207,12 +209,14 @@ parseRating f@File{ fileContent = Just (fromStrict -> input), .. } = handle onFa
       Left err -> throwM $ RatingYAMLCommentNotUnicode err
       Right ct -> return . assertM' (not . Text.null) . Text.strip $ toStrict ct
   let yamlInput = Lazy.ByteString.take documentEnd input
-  case YAML.decode1 yamlInput of
+  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

src/Handler/Utils/Submission.hs

@@ -485,6 +485,11 @@ msgSubmissionErrors = flip catches
                  <br>
                  <code .literal-error>
                    #{tshow unicodeErr}
+               $of RatingYAMLNotUnicode unicodeErr
+                 _{MsgRatingYAMLNotUnicode}
+                 <br>
+                 <code .literal-error>
+                   #{unicodeErr}
            |]
       RatingParseLegacyException pExc
         -> [whamlet|

src/Model/Rating.hs

@@ -16,6 +16,7 @@ data Rating = Rating
   , ratingSheetType :: SheetType
   , ratingValues :: Rating'
   } deriving (Read, Show, Eq, Generic, Typeable)
+    deriving anyclass (NFData)
 
 data Rating' = Rating'
   { ratingPoints :: Maybe Points
@@ -23,6 +24,7 @@ data Rating' = Rating'
   , ratingTime :: Maybe UTCTime
   , ratingDone :: Bool
   } deriving (Read, Show, Eq, Generic, Typeable)
+    deriving anyclass (NFData)
 
 data RatingValidityException
   = RatingNegative       -- ^ Rating points must be non-negative
@@ -47,6 +49,7 @@ data RatingParseException
   | RatingYAMLExceptionBeforeComment String -- ^ Could not parse YAML to determine where rating comments begin
   | RatingYAMLException String -- ^ Could not parse YAML
   | RatingYAMLCommentNotUnicode UnicodeException
+  | RatingYAMLNotUnicode String
   deriving (Show, Eq, Generic, Typeable)
   deriving anyclass (Exception)
 

src/Model/Types/DateTime.hs

@@ -27,8 +27,7 @@ import Data.Aeson.Types as Aeson
 
 data Season = Summer | Winter
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
-
+  deriving anyclass (Binary, Universe, Finite, NFData)
-instance Binary Season
 
 seasonToChar :: Season -> Char
 seasonToChar Summer = 'S'
@@ -47,8 +46,7 @@ data TermIdentifier = TermIdentifier
   { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
   , season :: Season
   } deriving (Show, Read, Eq, Ord, Generic, Typeable)
-
+    deriving anyclass (Binary, NFData)
-instance Binary TermIdentifier
 
 instance Enum TermIdentifier where
   -- ^ Do not use for conversion – Enumeration only

src/Model/Types/Sheet.hs

@@ -29,6 +29,7 @@ data SheetGrading
   | PassBinary -- non-zero means passed
   | PassAlways
   deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (NFData)
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
@@ -115,6 +116,7 @@ data SheetType
   | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
   deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (NFData)
 
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece