Multiple submission upload

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.

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

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,9 +73,49 @@ submissionTable = do
   headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
 
 
-getSubmissionListR :: Handler Html
+getSubmissionListR, postSubmissionListR :: Handler Html
-getSubmissionListR = do
+getSubmissionListR = postSubmissionListR
-  (submissionTable, selectEncoding) <- generateFormPost . withFragment $ submissionTable
+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")
 
@@ -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)

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

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

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

templates/submission-list.hamlet

@@ -1,3 +1,6 @@
+<form method=POST enctype=#{uploadEnctype} action=@{SubmissionListR}>
+  ^{uploadWidget}
+
 <form method=POST enctype=#{selectEncoding} target=_blank action=@{SubmissionDownloadMultiArchiveR}>
   ^{submissionTable}
   <button type=submit >Markierte herunterladen