From 76c9e611676ded7e301eecbf897f6257e1aef483 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Oct 2017 04:37:29 +0200 Subject: [PATCH] Deletion within Submissions --- models | 2 +- src/Handler/Submission.hs | 9 +++-- src/Handler/Utils/Zip/Rating.hs | 60 +++++++++++++++++++++++++++++---- templates/submission.hamlet | 23 +++++++++---- 4 files changed, 78 insertions(+), 16 deletions(-) diff --git a/models b/models index 469994b4f..7b7d0a666 100644 --- a/models +++ b/models @@ -103,8 +103,8 @@ SubmissionFile submissionId SubmissionId fileId FileId isUpdate Bool + isDeletion Bool UniqueSubmissionFile fileId submissionId isUpdate - UniqueFile fileId deriving Show SubmissionUser userId UserId diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 570442a75..b88f26828 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -55,11 +55,13 @@ getSubmissionDownloadSingleR cID path = do file <- (ratingFile cID' =<<) <$> getRating submissionID maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file False -> do - results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOn [E.don $ f E.^. FileTitle] $ do + results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID) E.where_ (f E.^. FileTitle E.==. E.val path) E.where_ . E.not_ . E.isNothing $ f E.^. FileContent + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f let fileName = Text.pack $ takeFileName path @@ -83,6 +85,8 @@ getSubmissionDownloadArchiveR path = do Just rating' -> do let fileEntitySource = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) + E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return f fileEntitySource' :: Source (YesodDB UniWorX) File fileEntitySource' = fileEntitySource =$= Conduit.map entityVal >> maybe (return ()) yield (ratingFile cID rating') @@ -111,8 +115,9 @@ postSubmissionR cID = do submissionId' <- runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate)) get404 submissionId' - files <- E.select . E.distinct . E.from $ \(sf `E.InnerJoin` f) -> do + files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] return (f, sf) return (submission, files) diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs index 83480672b..0924755e7 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/src/Handler/Utils/Zip/Rating.hs @@ -33,7 +33,7 @@ import Import hiding (()) import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import Control.Monad.Trans.Maybe -import Control.Monad.State +import Control.Monad.State hiding (forM_) import Data.Text (Text) import qualified Data.Text as Text @@ -261,7 +261,7 @@ sinkSubmission sheetId userId mExists = do sinkSubmission' :: SubmissionId -> Bool -- ^ Is this a correction -> Sink SubmissionContent (YesodDB UniWorX) () - sinkSubmission' submissionId isUpdate = evalStateLC mempty . Conduit.mapM_ $ \case + sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do alreadySeen <- gets (Set.member fileTitle . sinkFilenames) when alreadySeen . throwM $ DuplicateFileTitle fileTitle @@ -272,11 +272,12 @@ sinkSubmission sheetId userId mExists = do E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work - return f + return (f, sf) let anyChanges - | not (null collidingFiles) = any ((/= file) . entityVal) collidingFiles + | not (null collidingFiles) = any (/= file) [ f | (Entity _ f, _) <- collidingFiles ] | otherwise = True + undoneDeletion = any submissionFileIsDeletion [ sf | (_, Entity _ sf) <- collidingFiles ] -- The Eq Instance for File compares modification time exactly even -- though zip archives have very limited accuracy and range regarding -- timestamps. @@ -297,13 +298,18 @@ sinkSubmission sheetId userId mExists = do when anyChanges $ do touchSubmission when (not $ null collidingFiles) $ - lift $ deleteCascadeWhere [ FileId <-. map entityKey collidingFiles ] + lift $ deleteCascadeWhere [ FileId <-. [ fId | (Entity fId _, _) <- collidingFiles ] ] fileId <- lift $ insert file lift . insert_ $ SubmissionFile { submissionFileSubmissionId = submissionId , submissionFileFileId = fileId , submissionFileIsUpdate = isUpdate + , submissionFileIsDeletion = False } + when undoneDeletion $ do + touchSubmission + lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ] + Right (submissionId', Rating'{..}) -> do unless (submissionId' == submissionId) $ throwM ForeignRating @@ -313,7 +319,7 @@ sinkSubmission sheetId userId mExists = do unless isUpdate $ throwM RatingWithoutUpdate - s@(Submission{..}) <- lift $ getJust submissionId + Submission{..} <- lift $ getJust submissionId let anyChanges = or $ [ submissionRatingPoints /= ratingPoints @@ -341,3 +347,45 @@ sinkSubmission sheetId userId mExists = do True -> [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] tell $ mempty{ sinkSubmissionTouched = Any True } + finalize :: SubmissionSinkState -> YesodDB UniWorX () + finalize SubmissionSinkState{..} = do + missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do + E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + when (not isUpdate) $ + E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames) + E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] + + return (f, sf) + + case isUpdate of + False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ] + True -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do + shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do + E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate) + E.where_ $ f E.^. FileTitle E.==. E.val fileTitle + return $ f E.^. FileId + + case (shadowing, submissionFileIsUpdate) of + ([], _) -> deleteCascade fileId + (E.Value f:_, False) -> do + insert_ $ SubmissionFile + { submissionFileSubmissionId = submissionId + , submissionFileFileId = f + , submissionFileIsUpdate = True + , submissionFileIsDeletion = True + } + (E.Value f:_, True) -> do + update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ] + deleteCascade fileId + + when (isUpdate && not (getAny sinkSeenRating)) $ + update submissionId + [ SubmissionRatingTime =. Nothing + , SubmissionRatingPoints =. Nothing + , SubmissionRatingBy =. Nothing + , SubmissionRatingComment =. Nothing + ] diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 84d568b56..389b651d8 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -35,11 +35,20 @@ Replace
^{uploadWidget} - -
- $forall (Entity _ file, Entity _ sFile) <- files - - #{fileTitle file} - $if submissionFileIsUpdate sFile - Korrigiert + +
+
+ Files & Directories +