From 306fb351adb3834d7dc381c0770712d2a1cf9bba Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 12 Dec 2018 12:05:22 +0100 Subject: [PATCH] =?UTF-8?q?Error=20Handling=20f=C3=BCr=20SinkSubmission?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- messages/uniworx/de.msg | 9 ++++++++- src/Foundation.hs | 1 + src/Handler/Corrections.hs | 31 ++++++++++++++++--------------- src/Handler/Submission.hs | 22 +++++++++++----------- src/Handler/Utils/Submission.hs | 30 +++++++++++++----------------- src/Import/NoFoundation.hs | 1 + src/Model/Submission.hs | 22 ++++++++++++++++++++++ 7 files changed, 72 insertions(+), 44 deletions(-) create mode 100644 src/Model/Submission.hs diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index af38effd0..2ee21fdf2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -234,7 +234,7 @@ CorrUploadField: Korrekturen CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen CorrAutoSetCorrector: Korrekturen verteilen -NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! +NatField name@Text: #{name} muss eine natürliche Zahl sein! JSONFieldDecodeFailure aesonFailure@String: Konnte JSON nicht parsen: #{aesonFailure} SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: @@ -295,6 +295,13 @@ RatingExceedsMax: Bewertung übersteigt die erlaubte Maximalpunktzahl RatingNotExpected: Keine Bewertungen erlaubt RatingBinaryExpected: Bewertung muss 0 (=durchgefallen) oder 1 (=bestanden) sein +SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file} kommt mehrfach im Zip-Archiv vor +SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden. +SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich. +SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen! + +MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error} + NoTableContent: Kein Tabelleninhalt NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter diff --git a/src/Foundation.hs b/src/Foundation.hs index cf3483b6d..5f2795e56 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -199,6 +199,7 @@ embedRenderMessage ''UniWorX ''StudyFieldType id embedRenderMessage ''UniWorX ''SheetFileType 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 embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b77167ca8..ba494b409 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -580,13 +580,12 @@ postCorrectionR tid ssh csh shn cid = do FormSuccess fileUploads -> do uid <- requireAuthId - void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True - {-case res of - (Left _) -> addMessageI Success MsgRatingFilesUpdated - (Right RatingNotExpected) -> addMessageI Error MsgRatingNotExpected - (Right other) -> throw other-} - - redirect $ CSubmissionR tid ssh csh shn cid CorrectionR + res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True + case res of + Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors + (Just _) -> do + addMessageI Success MsgRatingFilesUpdated + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR mr <- getMessageRender let sheetTypeDesc = mr sheetType @@ -621,13 +620,15 @@ postCorrectionsUploadR = do FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess files -> do uid <- requireAuthId - subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True - if - | null subs -> addMessageI Warning MsgNoCorrectionsUploaded - | otherwise -> do - subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] - mr <- (toHtml .) <$> getMessageRender - addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) + mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True + case mbSubs of + Nothing -> return () + (Just subs) + | null subs -> addMessageI Warning MsgNoCorrectionsUploaded + | otherwise -> do + subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] + mr <- (toHtml .) <$> getMessageRender + addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) defaultLayout $ @@ -671,7 +672,7 @@ postCorrectionsCreateR = do FormMissing -> return () FormFailure errs -> forM_ errs $ addMessage Error . toHtml FormSuccess (sid, (pss, invalids)) -> do - allDone <- fmap getAll . execWriterT $ do + allDone <- fmap getAll . execWriterT $ do forM_ (Map.toList invalids) $ \((oPseudonyms, iPseudonym), alts) -> $(addMessageFile Error "templates/messages/ignoredInvalidPseudonym.hamlet") tell . All $ null invalids diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 7129dfeeb..a011f5295 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -4,7 +4,7 @@ import Import import Jobs --- import Yesod.Form.Bootstrap3 +-- import Yesod.Form.Bootstrap3 import Handler.Utils import Handler.Utils.Submission @@ -55,7 +55,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing flip (renderAForm FormStandard) html $ (,) <$> fileUploadForm - <*> ( (:|) + <*> ( (:|) -- #227 Part I: change aforced to areq if the user is the lecturer or an admin (lecturer can upload for students) <$> aforced ciField (fslpI (MsgSubmissionMember 1) "user@campus.lmu.de" ) self <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy @@ -66,7 +66,7 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identForm FIDsu <* submitButton where (groupNr, editableBuddies) - | Arbitrary{..} <- grouping = (maxParticipants, True) + | Arbitrary{..} <- grouping = (maxParticipants, True) | RegisteredGroups <- grouping = (fromIntegral $ length buddies, False) | otherwise = (0, False) @@ -140,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) - + shid' <- submissionSheet <$> get404 smid unless (shid == shid') $ invalidArgsI [MsgSubmissionWrongSheet] @@ -169,7 +169,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time return (csheet,buddies,lastEdits) ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies) - mCID <- runDBJobs $ do + mCID <- (fmap join) . msgSubmissionErrors . runDBJobs $ do res' <- case res of FormMissing -> return FormMissing (FormFailure failmsgs) -> return $ FormFailure failmsgs @@ -193,7 +193,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do E.&&. submission E.^. SubmissionSheet E.==. E.val shid case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3 Nothing -> return () - Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid + Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid return $ E.countRows E.>. E.val (0 :: Int64) return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted)) @@ -252,7 +252,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do return $ Just cID (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml) _other -> return Nothing - + case mCID of Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () @@ -281,7 +281,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime in timeCell fileTime ] - coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) + coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File)) coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md) submissionFiles :: _ -> _ -> E.SqlQuery _ submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do @@ -349,7 +349,7 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat case results of [Entity _ File{ fileContent = Just c, fileTitle }] -> do - whenM downloadFiles $ + whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () @@ -359,13 +359,13 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do - when (sfType == SubmissionCorrected) $ + when (sfType == SubmissionCorrected) $ guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | otherwise = ZIPArchiveName $ toPathPiece cID - + addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] respondSourceDB "application/zip" $ do submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 3d405fff8..0730f157d 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -5,6 +5,7 @@ module Handler.Utils.Submission , submissionFileSource, submissionFileQuery , submissionMultiArchive , SubmissionSinkException(..) + , msgSubmissionErrors -- wrap around sinkSubmission/sinkMultiSubmission, but outside of runDB! , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet ) where @@ -267,14 +268,6 @@ instance Monoid SubmissionSinkState where mempty = memptydefault mappend = mappenddefault -data SubmissionSinkException = DuplicateFileTitle FilePath - | DuplicateRating - | RatingWithoutUpdate - | ForeignRating CryptoFileNameSubmission - deriving (Typeable, Show) - -instance Exception SubmissionSinkException - submissionBlacklist :: [Pattern] submissionBlacklist = $(patternFile compDefault "config/submission-blacklist") @@ -311,6 +304,18 @@ extractRatingsMsg = do mr <- (toHtml . ) <$> getMessageRender addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr) +-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann! +msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a) +msgSubmissionErrors = flip catches + [ E.Handler $ \e -> Nothing <$ addMessageI Error (e :: RatingException) + , E.Handler $ \e -> Nothing <$ addMessageI Error (e :: SubmissionSinkException) + , E.Handler $ \(SubmissionSinkException sinkId _ sinkEx) -> do + mr <- getMessageRender + addMessageI Error $ MsgMultiSinkException (toPathPiece sinkId) (mr sinkEx) + return Nothing + ] . fmap Just + + sinkSubmission :: UserId -> Either SheetId SubmissionId -> Bool -- ^ Is this a correction @@ -510,15 +515,6 @@ sinkSubmission userId mExists isUpdate = do -> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId | otherwise -> return () -data SubmissionMultiSinkException - = SubmissionSinkException - { _submissionSinkId :: CryptoFileNameSubmission - , _submissionSinkFedFile :: Maybe FilePath - , _submissionSinkException :: SubmissionSinkException - } - deriving (Typeable, Show) - -instance Exception SubmissionMultiSinkException sinkMultiSubmission :: UserId -> Bool {-^ Are these corrections -} diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 868ba4b67..91cebefe8 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -8,6 +8,7 @@ import Model as Import import Model.Types.JSON as Import import Model.Migration as Import import Model.Rating as Import +import Model.Submission as Import import Settings as Import import Settings.StaticFiles as Import import Yesod.Auth as Import diff --git a/src/Model/Submission.hs b/src/Model/Submission.hs new file mode 100644 index 000000000..0f931911b --- /dev/null +++ b/src/Model/Submission.hs @@ -0,0 +1,22 @@ +module Model.Submission where + +import ClassyPrelude.Yesod +import CryptoID + +data SubmissionSinkException = DuplicateFileTitle FilePath + | DuplicateRating + | RatingWithoutUpdate + | ForeignRating CryptoFileNameSubmission + deriving (Typeable, Show) + +instance Exception SubmissionSinkException + +data SubmissionMultiSinkException + = SubmissionSinkException + { _submissionSinkId :: CryptoFileNameSubmission + , _submissionSinkFedFile :: Maybe FilePath + , _submissionSinkException :: SubmissionSinkException + } + deriving (Typeable, Show) + +instance Exception SubmissionMultiSinkException