From 0d01ac95ab86de85f22fb17e821a7042f6bde3e0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 1 Jul 2018 14:49:15 +0200 Subject: [PATCH] Corrections upload --- messages/de.msg | 4 +++- src/Foundation.hs | 2 ++ src/Handler/Corrections.hs | 18 +++++++++++++++++- src/Handler/Utils/Submission.hs | 18 ++++++++++++++---- src/Handler/Utils/Zip.hs | 2 +- templates/corrections-upload.hamlet | 2 ++ templates/messages/correctionsUploaded.hamlet | 6 ++++++ 7 files changed, 45 insertions(+), 7 deletions(-) create mode 100644 templates/corrections-upload.hamlet create mode 100644 templates/messages/correctionsUploaded.hamlet diff --git a/messages/de.msg b/messages/de.msg index 9f1ddd03a..77f35e422 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -142,4 +142,6 @@ UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neue NoCorrector: Kein Korrektor RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt. -CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: \ No newline at end of file +CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden: + +CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert: \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index b729ad7df..8f466ef20 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -765,6 +765,8 @@ pageHeading (CourseR tid csh CShowR) toWidget courseName pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle +pageHeading CorrectionsUploadR + = Just $ i18nHeading MsgCorrUpload -- (CourseR tid csh CRegisterR) -- just for POST pageHeading (CourseR tid csh CEditR) = Just $ i18nHeading $ MsgCourseEditHeading tid csh diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 1350efb13..fefec4dd6 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -351,4 +351,20 @@ getCorrectionUserR tid csh shn cid = undefined getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR -postCorrectionsUploadR = undefined +postCorrectionsUploadR = do + ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $ + areq (zipFileField True) (fslI MsgCorrUploadField) Nothing + <* submitButton + + case uploadRes of + FormMissing -> return () + FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs + FormSuccess files -> do + uid <- requireAuthId + subs <- runDB . runConduit $ transPipe lift files .| extractRatings .| sinkMultiSubmission uid True + subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] + mr <- (toHtml .) <$> getMessageRender + addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) + + defaultLayout $ do + $(widgetFile "corrections-upload") diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 10ac1f07f..a337f59d3 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -18,7 +18,7 @@ module Handler.Utils.Submission , submissionFileSource, submissionFileQuery , submissionMultiArchive , SubmissionSinkException(..) - , sinkSubmission + , sinkSubmission, sinkMultiSubmission , submissionMatchesSheet ) where @@ -381,7 +381,7 @@ sinkMultiSubmission :: UserId -- -- 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). -- --- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR` -- TODO +-- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR` sinkMultiSubmission userId isUpdate = do let feed :: SubmissionId @@ -395,7 +395,16 @@ sinkMultiSubmission userId isUpdate = do sink <- case mSink of Just sink -> return sink Nothing -> do - -- Submission{..} <- lift $ get404 sId + lift $ do + Submission{..} <- get404 sId + cID <- encrypt sId + Sheet{..} <- get404 submissionSheet + Course{..} <- get404 sheetCourse + authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True + case authRes of + AuthenticationRequired -> notAuthenticated + Unauthorized t -> permissionDenied t + Authorized -> return () return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate sink' <- lift $ yield val ++$$ sink case sink' of @@ -405,13 +414,14 @@ sinkMultiSubmission userId isUpdate = do v@(Right (sId, _)) -> lift $ feed sId v (Left f@File{..}) -> do let - tryDecrypt :: FilePath -> _ (Either CryptoIDError SubmissionId) + tryDecrypt :: FilePath -> _ (Either SomeException 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 + $logDebugS "sinkMultiSubmission" $ tshow (splitDirectories fileTitle, msId, fileTitle') lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' } fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index b972555a7..d40716168 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -108,7 +108,7 @@ sourceFiles fInfo acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File acceptFile fInfo = do - let fileTitle = unpack $ fileName fInfo + let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo fileModified <- liftIO getCurrentTime fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC) return File{..} diff --git a/templates/corrections-upload.hamlet b/templates/corrections-upload.hamlet new file mode 100644 index 000000000..7def9e44d --- /dev/null +++ b/templates/corrections-upload.hamlet @@ -0,0 +1,2 @@ +
+ ^{upload} diff --git a/templates/messages/correctionsUploaded.hamlet b/templates/messages/correctionsUploaded.hamlet new file mode 100644 index 000000000..2edd0288b --- /dev/null +++ b/templates/messages/correctionsUploaded.hamlet @@ -0,0 +1,6 @@ +_{MsgCorrectionsUploaded (genericLength subs')} + +