diff --git a/package.yaml b/package.yaml
index eb57855af..012fb7d07 100644
--- a/package.yaml
+++ b/package.yaml
@@ -70,6 +70,7 @@ dependencies:
- mime-types
- generic-deriving
- blaze-html
+- conduit-resumablesink >=0.2
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
diff --git a/routes b/routes
index 25e51ee2a..afb0adb90 100644
--- a/routes
+++ b/routes
@@ -18,7 +18,7 @@
/course/#TermIdentifier/#Text/edit CourseEditExistR GET
/course/#TermIdentifier/#Text/show CourseShowR GET POST
-/submission SubmissionListR GET
+/submission SubmissionListR GET POST
/submission/#CryptoUUIDSubmission SubmissionR GET POST
/submissions.zip SubmissionDownloadMultiArchiveR POST
!/submission/archive/#FilePath SubmissionDownloadArchiveR GET
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index 8a38fe96d..ffb7ac937 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -7,10 +7,11 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE LambdaCase #-}
module Handler.Submission where
-import Import
+import Import hiding (joinPath)
import Yesod.Form.Bootstrap3
@@ -19,6 +20,8 @@ import Handler.Utils
import Network.Mime
import Control.Monad.Trans.Maybe
+import Control.Monad.State.Class
+import Control.Monad.Trans.State.Strict (StateT)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
@@ -30,6 +33,10 @@ import qualified CryptoID.Base32 as Base32
import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as Conduit
+import Data.Conduit.ResumableSink
+
+import Data.Map (Map)
+import qualified Data.Map as Map
import System.FilePath
@@ -66,10 +73,50 @@ submissionTable = do
headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
-getSubmissionListR :: Handler Html
-getSubmissionListR = do
- (submissionTable, selectEncoding) <- generateFormPost . withFragment $ submissionTable
-
+getSubmissionListR, postSubmissionListR :: Handler Html
+getSubmissionListR = postSubmissionListR
+postSubmissionListR = do
+ ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
+ <$> areq checkBoxField (bfs ("Dies sind Korrekturen" :: Text)) (Just False)
+ <*> fileAFormReq (bfs ("Archiv" :: Text))
+ <* bootstrapSubmit ("Mehrere Hochladen" :: BootstrapSubmit Text)
+
+ runDB $ do
+ case uploadResult of
+ FormMissing -> return ()
+ FormFailure _ -> setMessage "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 submissionSheetId 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
+ cIDKey <- getsYesod appCryptoIDKey
+ sId <- Base32.decrypt cIDKey (CryptoID . CI.mk $ Text.pack 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
+
+ (submissionTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
+
defaultLayout $(widgetFile "submission-list")
getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
@@ -201,6 +248,7 @@ postSubmissionR cID = do
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.^. SubmissionFileFileId)
+ E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId)
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
return (f, sf)
return (submission, files)
diff --git a/src/Handler/Utils/Rating.hs b/src/Handler/Utils/Rating.hs
index 696cbd2b6..d5626e3b1 100644
--- a/src/Handler/Utils/Rating.hs
+++ b/src/Handler/Utils/Rating.hs
@@ -200,7 +200,7 @@ isRatingFile fName
decryptErrors err = throwM err
isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
-isRatingFile' (normalise -> fName)
+isRatingFile' (takeFileName -> fName)
| (bName, ".txt") <- splitExtension fName
, Just (CI.mk . Text.pack -> ciphertext) <- stripPrefix "bewertung_" bName
= Just CryptoID{..}
diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs
index 62c55fcf7..ee745e16c 100644
--- a/src/Handler/Utils/Submission.hs
+++ b/src/Handler/Utils/Submission.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
@@ -30,6 +31,8 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as Conduit
+import qualified Data.Text as Text
+
data SubmissionSinkState = SubmissionSinkState
{ sinkSeenRating :: Any
@@ -85,6 +88,8 @@ sinkSubmission sheetId userId mExists = do
-> Sink SubmissionContent (YesodDB UniWorX) ()
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
Left file@(File{..}) -> do
+ $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
+
alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
when alreadySeen . throwM $ DuplicateFileTitle fileTitle
tell $ mempty{ sinkFilenames = Set.singleton fileTitle }
@@ -148,6 +153,8 @@ sinkSubmission sheetId userId mExists = do
lift $ deleteWhere [ SubmissionFileId <-. [ sfId | (_, Entity sfId sf) <- collidingFiles, submissionFileIsDeletion sf ] ]
Right (submissionId', Rating'{..}) -> do
+ $logDebugS "sinkSubmission" $ tshow submissionId'
+
unless (submissionId' == submissionId) $ throwM ForeignRating
alreadySeen <- gets $ getAny . sinkSeenRating
diff --git a/stack.yaml b/stack.yaml
index 7cc6221eb..96f4eea15 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -6,6 +6,10 @@ nix:
extra-package-dbs: []
packages:
- .
+- location:
+ git: https://github.com/pngwjpgh/conduit-resumablesink.git
+ commit: ee0679dc31cdcedb2dad240b941262b9dc16f06d
+ extra-dep: true
extra-deps:
- colonnade-1.1.1
- yesod-colonnade-1.1.0
diff --git a/templates/submission-list.hamlet b/templates/submission-list.hamlet
index a349dd2a3..33faf8cb2 100644
--- a/templates/submission-list.hamlet
+++ b/templates/submission-list.hamlet
@@ -1,3 +1,6 @@
+