Corrections upload

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:
+CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
+
+CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:

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

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")

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
 

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{..}

templates/corrections-upload.hamlet

@@ -0,0 +1,2 @@
+<form method=POST enctype=#{uploadEncoding}>
+  ^{upload}

templates/messages/correctionsUploaded.hamlet

@@ -0,0 +1,6 @@
+_{MsgCorrectionsUploaded (genericLength subs')}
+
+<ul>
+  $forall cID <- subs'
+    <li>
+      #{toPathPiece cID}