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 @@