From 99832c128605e504ecc3a67c99f8783978a0f1c1 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 30 Jun 2018 21:16:11 +0200 Subject: [PATCH] Cleanup submission download --- messages/de.msg | 2 + routes | 19 ++-- src/Foundation.hs | 2 - src/Handler/Corrections.hs | 2 +- src/Handler/Submission.hs | 174 +++----------------------------- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/Submission.hs | 83 +++++++++++---- templates/adminTest.hamlet | 5 +- templates/corrections.hamlet | 2 +- 9 files changed, 93 insertions(+), 198 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index 8f5ef4442..9f1ddd03a 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -131,6 +131,8 @@ NrColumn: Nr SelectColumn: Auswahl CorrDownload: Herunterladen +CorrUploadField: Korrekturen +CorrUpload: Korrekturen hochladen CorrSetCorrector: Korrektor zuweisen CorrAutoSetCorrector: Korrekturen verteilen NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! diff --git a/routes b/routes index 7c13ce3e1..fa34e27ae 100644 --- a/routes +++ b/routes @@ -56,26 +56,19 @@ !/ex/new SheetNewR GET POST /ex/#Text SheetR: /show SShowR GET !timeANDregistered !timeANDmaterials !corrector - !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /edit SEditR GET POST /delete SDelR GET POST - !/sub/new SubmissionNewR GET POST !timeANDregistered - !/sub/own SubmissionOwnR GET !free + /sub/new SubmissionNewR GET POST !timeANDregistered + /sub/own SubmissionOwnR GET !free + !/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector !/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector + !/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector /correctors SCorrR GET POST /subs SSubsR GET POST + !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector /corrections CorrectionsR GET POST !free --- TODO below -!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated -!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated - -/submission SubmissionListR GET !deprecated -/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated -/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated --- TODO above - !/#UUID CryptoUUIDDispatchR GET !free -- just redirect -!/*{CI FilePath} CryptoFileNameDispatchR GET !free +-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists diff --git a/src/Foundation.hs b/src/Foundation.hs index 7fbf37604..c70a713c0 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -610,8 +610,6 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - -- Deprecated below - breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) -- Others breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 97651dcfd..c1d50ac06 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -192,7 +192,7 @@ data ActionCorrectionsData = CorrDownloadData correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Widget)) -> Handler TypedContent correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do tableForm <- makeCorrectionsTable whereClause displayColumns psValidator - ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do + ((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf (actionRes, action) <- multiAction actions return ((,) <$> actionRes <*> selectionRes, table <> action) diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index b4ccdfd76..bd329cf7e 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -205,7 +205,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do (Nothing, Just smid) -- no new files, existing submission partners updated -> return smid (Just files, _) -- new files - -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid) + -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False _ -> error "Impossible, because of definition of `makeSubmissionForm`" -- Determine members of pre-registered group groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do @@ -240,7 +240,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) colonnadeFiles cid = mconcat -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle) + [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle) (\(Entity _ File{..}) -> str2widget fileTitle) , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified ] @@ -267,7 +267,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do $maybe arCid <- mArCid

- Archiv + Archiv $forall (name,time) <- lastEdits
last edited by #{name} at #{formatTimeGerDTlong time} $maybe fileTable <- mFileTable @@ -276,14 +276,15 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do |] - - - -getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent -getSubmissionDownloadSingleR cID path = do +getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent +getSubmissionDownloadSingleR tid csh shn cID path = do submissionID <- decrypt cID runDB $ do + shid <- fetchSheetId tid csh shn + Submission{..} <- get404 submissionID + when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] + isRating <- maybe False (== submissionID) <$> isRatingFile path case isRating of True -> do @@ -304,11 +305,16 @@ getSubmissionDownloadSingleR cID path = do [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c) _ -> notFound -getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent -getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do +getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent +getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do submissionID <- decrypt cID cUUID <- encrypt submissionID respondSourceDB "application/zip" $ do + lift $ do + shid <- fetchSheetId tid csh shn + Submission{..} <- get404 submissionID + when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] + rating <- lift $ getRating submissionID case rating of Nothing -> lift notFound @@ -317,151 +323,3 @@ getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) } fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder - - - - - - - ------------------------------------------------------------------------------------------------ -------------------------- DEMO BELOW - - -submissionTable :: MForm Handler (FormResult [SubmissionId], Widget) -submissionTable = do - subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet - - return (sub, sheet, course) - - cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) -> - (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s - - let - anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR - courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName - anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID - submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID - colonnade = mconcat - [ headed "Abgabe-ID" $ Yesod.anchorCell anchorSubmission submissionText - , headed "Kurs" $ Yesod.anchorCell anchorCourse courseText - , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> Yesod.textCell $ sheetName - ] - toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission - toExternal (_, cID, _) = return cID - fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId - fromExternal = decrypt - headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs - - -getSubmissionListR, postSubmissionListR :: Handler Html -getSubmissionListR = postSubmissionListR -postSubmissionListR = do - ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) - <$> areq checkBoxField "Dies sind Korrekturen" (Just False) - <*> fileAFormReq "Archiv" - <* submitButton - - runDB $ do - case uploadResult of - FormMissing -> return () - FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren." - FormSuccess (isUpdate, fInfo) -> do - userId <- lift requireAuthId - let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) () - feed sId val = do - mSink <- gets $ Map.lookup sId - sink <- case mSink of - Just sink -> return sink - Nothing -> do - Submission{..} <- lift $ get404 sId - return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate)) - sink' <- lift $ yield val ++$$ sink - case sink' of - Left _ -> error "sinkSubmission returned prematurely" - Right nSink -> modify $ Map.insert sId nSink - sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) () - sinkSubmissions = do - sinks <- execStateC Map.empty . awaitForever $ \case - v@(Right (sId, _)) -> lift $ feed sId v - (Left f@File{..}) -> case splitDirectories fileTitle of - (cID:rest) - | not (null rest) -> do - sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission) - lift . feed sId $ Left f{ fileTitle = joinPath rest } - | otherwise -> return () - [] -> invalidArgs ["Encountered file/directory with empty name"] - lift $ mapM_ (void . closeResumableSink) sinks - - runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions - - (subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable - - defaultLayout $(widgetFile "submission-list") - - - -postSubmissionDownloadMultiArchiveR :: Handler TypedContent -postSubmissionDownloadMultiArchiveR = do - ((selectResult, _), _) <- runFormPost . withFragment $ submissionTable - - case selectResult of - FormMissing -> invalidArgs ["Missing submission numbers"] - FormFailure errs -> invalidArgs errs - FormSuccess ids -> submissionMultiArchive (Set.fromList ids) - - - - -getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html -getSubmissionDemoR = postSubmissionDemoR -postSubmissionDemoR cID = do - submissionId <- decrypt cID - - ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,) - <$> areq checkBoxField "Dies ist eine Korrektur" (Just False) - <*> fileAFormReq "Datei" - <* submitButton - - (submission, files) <- runDB $ do - submission <- do - submission@Submission{..} <- get404 submissionId - case uploadResult of - FormMissing -> return submission - FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren." - FormSuccess (isUpdate, fInfo) -> do - userId <- lift requireAuthId - let mimeType = defaultMimeLookup (fileName fInfo) - source - | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip - | otherwise = do - let fileTitle = Text.unpack $ fileName fInfo - fileModified <- liftIO getCurrentTime - yieldM $ do - fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC) - return File{..} - submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate)) - get404 submissionId' - - 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.^. SubmissionFileFile) - E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId) - E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] - return (f, sf) - return (submission, files) - - let - Rating'{..} = Rating' - { ratingPoints = submissionRatingPoints submission - , ratingComment = submissionRatingComment submission - , ratingTime = submissionRatingTime submission - } - - cID' <- encrypt submissionId - let - archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission) - archiveName = archiveBaseName <.> "zip" - - defaultLayout $(widgetFile "submission") diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3d233f6f1..c8d4bf3c0 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -52,7 +52,7 @@ import Control.Monad.Writer.Class -- Unique Form Identifiers to avoid accidents -- ------------------------------------------------ -data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors +data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrectionsUpload deriving (Enum, Eq, Ord, Bounded, Read, Show) diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index dd99a6d9c..8cf22e67d 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} module Handler.Utils.Submission @@ -20,13 +21,13 @@ module Handler.Utils.Submission , sinkSubmission ) where -import Import hiding ((.=)) +import Import hiding ((.=), joinPath) import Control.Lens import Control.Lens.Extras (is) import Utils.Lens -import Control.Monad.State hiding (forM_, mapM_) +import Control.Monad.State hiding (forM_, mapM_,foldM) import qualified Control.Monad.Random as Rand import Data.Maybe @@ -49,6 +50,9 @@ import Handler.Utils.Zip import qualified Database.Esqueleto as E import qualified Data.Conduit.List as Conduit +import Data.Conduit.ResumableSink + +import System.FilePath data AssignSubmissionException = NoCorrectorsByProportion @@ -185,9 +189,9 @@ data SubmissionSinkException = DuplicateFileTitle FilePath instance Exception SubmissionSinkException -sinkSubmission :: SheetId - -> UserId - -> Maybe (SubmissionId, Bool {-^ Is this a correction -}) +sinkSubmission :: UserId + -> Either SheetId SubmissionId + -> Bool -- ^ Is this a correction -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId -- ^ Replace the currently saved files for the given submission (either -- corrected files or original ones, depending on arguments) with the supplied @@ -197,25 +201,28 @@ sinkSubmission :: SheetId -- are deleted (or marked as deleted in the case of this being a correction). -- -- A 'Submission' is created if no 'SubmissionId' is supplied -sinkSubmission sheetId userId mExists = do - now <- liftIO getCurrentTime - let - submissionSheet = sheetId - submissionRatingPoints = Nothing - submissionRatingComment = Nothing - submissionRatingBy = Nothing - submissionRatingTime = Nothing - - (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists - +sinkSubmission userId mExists isUpdate = do + sId <- lift $ case mExists of + Left sheetId -> do + let + submissionSheet = sheetId + submissionRatingPoints = Nothing + submissionRatingComment = Nothing + submissionRatingBy = Nothing + submissionRatingTime = Nothing + sId <- insert Submission{..} + -- now <- liftIO getCurrentTime + -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty + return sId + Right sId -> return sId sId <$ sinkSubmission' sId isUpdate where tell = modify . mappend sinkSubmission' :: SubmissionId - -> Bool -- ^ Is this a correction - -> Sink SubmissionContent (YesodDB UniWorX) () + -> Bool -- ^ Is this a correction + -> Sink SubmissionContent (YesodDB UniWorX) () sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case Left file@(File{..}) -> do $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle) @@ -363,3 +370,43 @@ sinkSubmission sheetId userId mExists = do , SubmissionRatingBy =. Nothing , SubmissionRatingComment =. Nothing ] + +sinkMultiSubmission :: UserId + -> Bool {-^ Are these corrections -} + -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId) + +-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'. +-- +-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction). +sinkMultiSubmission userId isUpdate = do + let + feed :: SubmissionId + -> SubmissionContent + -> StateT + (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) + (YesodDB UniWorX) + () + feed sId val = do + mSink <- gets $ Map.lookup sId + sink <- case mSink of + Just sink -> return sink + Nothing -> do + -- Submission{..} <- lift $ get404 sId + return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate + sink' <- lift $ yield val ++$$ sink + case sink' of + Left _ -> error "sinkSubmission returned prematurely" + Right nSink -> modify $ Map.insert sId nSink + sinks <- execStateLC Map.empty . awaitForever $ \case + v@(Right (sId, _)) -> lift $ feed sId v + (Left f@File{..}) -> do + let + tryDecrypt :: FilePath -> _ (Either CryptoIDError SubmissionId) + tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission) + acc (Just cID, fp) segment = return (Just cID, fp ++ [segment]) + acc (Nothing , fp) segment = do + msId <- tryDecrypt segment + return . either (const id) (set _1 . Just) msId $ (Nothing, fp) + (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle + lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' } + fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks diff --git a/templates/adminTest.hamlet b/templates/adminTest.hamlet index 66e2b891c..d18c0b156 100644 --- a/templates/adminTest.hamlet +++ b/templates/adminTest.hamlet @@ -36,10 +36,7 @@ Neues Semester anlegen
  • - Kurse anlegen - -
  • - Dateien hochladen und abrufen + Kurse anlegen
    diff --git a/templates/corrections.hamlet b/templates/corrections.hamlet index 6739d0a9e..766cda831 100644 --- a/templates/corrections.hamlet +++ b/templates/corrections.hamlet @@ -2,4 +2,4 @@
    ^{table}