Cleanup submission download

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!

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/new                   SubmissionNewR GET POST        !timeANDregistered
-    !/sub/own                   SubmissionOwnR GET             !free
+    /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

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
 

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)

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
         <hr>
         <h2>
-          <a href=@{SubmissionDownloadArchiveR arCid}>Archiv
+          <a href=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv
         $forall (name,time) <- lastEdits
           <div>last edited by #{name} at #{formatTimeGerDTlong time}
         $maybe fileTable <- mFileTable
@@ -276,14 +276,15 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
     |]
 
 
-
+getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent
-
+getSubmissionDownloadSingleR tid csh shn cID path = do
-
-getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
-getSubmissionDownloadSingleR 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 :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent
-getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
+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")

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)
 
 

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
+sinkSubmission :: UserId
-               -> UserId
+               -> Either SheetId SubmissionId
-               -> Maybe (SubmissionId, Bool {-^ Is this a correction -})
+               -> 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
+sinkSubmission userId mExists isUpdate = do
-  now <- liftIO getCurrentTime
+  sId <- lift $ case mExists of
-  let
+    Left sheetId -> do
-    submissionSheet       = sheetId
+      let
-    submissionRatingPoints  = Nothing
+        submissionSheet         = sheetId
-    submissionRatingComment = Nothing
+        submissionRatingPoints  = Nothing
-    submissionRatingBy      = Nothing
+        submissionRatingComment = Nothing
-    submissionRatingTime    = Nothing
+        submissionRatingBy      = Nothing
-
+        submissionRatingTime    = Nothing
-  (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists
+      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
+                    -> Bool -- ^ Is this a correction
-                   -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> 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

templates/adminTest.hamlet

@@ -36,10 +36,7 @@
       <a href=@{TermEditR}>Neues Semester anlegen
 
     <li .list-group-item>
-                        <a href=@{CourseNewR}>Kurse anlegen
+      <a href=@{CourseNewR}>Kurse anlegen
-
-    <li .list-group-item>
-      <a href=@{SubmissionListR}>Dateien hochladen und abrufen
 
 <hr>
 <div .container>

templates/corrections.hamlet

@@ -2,4 +2,4 @@
   <form method=POST enctype=#{tableEncoding}>
     ^{table}
     <button type=submit>
-      Do stuff
+      _{MsgBtnSubmit}