From c87315006df39550a58d89bcb5491a0afe0e4481 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 19 Jun 2020 17:38:48 +0200 Subject: [PATCH] fix(ratings): improve decoding error reporting --- config/mimetypes | 1 + frontend/src/utils/alerts/alerts.sass | 2 +- messages/uniworx/de-de-formal.msg | 1 + messages/uniworx/en-eu.msg | 1 + src/Handler/Utils/Rating.hs | 30 +++++++++++++++++++++++---- src/Handler/Utils/Rating/Format.hs | 8 +++++-- src/Handler/Utils/Submission.hs | 5 +++++ src/Model/Rating.hs | 3 +++ src/Model/Types/DateTime.hs | 6 ++---- src/Model/Types/Sheet.hs | 2 ++ 10 files changed, 48 insertions(+), 11 deletions(-) diff --git a/config/mimetypes b/config/mimetypes index 5d3158e6e..552a57179 100644 --- a/config/mimetypes +++ b/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 diff --git a/frontend/src/utils/alerts/alerts.sass b/frontend/src/utils/alerts/alerts.sass index 937ddc42f..c55829aab 100644 --- a/frontend/src/utils/alerts/alerts.sass +++ b/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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 190b73635..361eff638 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 7a37a0cae..f2635b4ba 100644 --- a/messages/uniworx/en-eu.msg +++ b/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 diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs index 2d845e0d8..ec622fad0 100644 --- a/src/Handler/Utils/Rating.hs +++ b/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 $ - fmap getFirst . flip foldMapM segments' $ fmap First . tryDecrypt +isRatingFile (takeFileName -> fName) = liftHandler . runMaybeT $ do + 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' diff --git a/src/Handler/Utils/Rating/Format.hs b/src/Handler/Utils/Rating/Format.hs index a34391a45..b26e022fa 100644 --- a/src/Handler/Utils/Rating/Format.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 6612c6f16..f36a1158f 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -485,6 +485,11 @@ msgSubmissionErrors = flip catches
#{tshow unicodeErr} + $of RatingYAMLNotUnicode unicodeErr + _{MsgRatingYAMLNotUnicode} +
+ + #{unicodeErr} |] RatingParseLegacyException pExc -> [whamlet| diff --git a/src/Model/Rating.hs b/src/Model/Rating.hs index d1ca14da4..c0a89ec82 100644 --- a/src/Model/Rating.hs +++ b/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) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index db1a8f9d7..16942e98a 100644 --- a/src/Model/Types/DateTime.hs +++ b/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) - -instance Binary Season + deriving anyclass (Binary, Universe, Finite, NFData) 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) - -instance Binary TermIdentifier + deriving anyclass (Binary, NFData) instance Enum TermIdentifier where -- ^ Do not use for conversion – Enumeration only diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 99b5e521d..a35553fa9 100644 --- a/src/Model/Types/Sheet.hs +++ b/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