From 37a983619317bd6e99fd0b7270a2daef059284a2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 12 Oct 2017 02:14:23 +0200 Subject: [PATCH] Submission Upload --- package.yaml | 1 + src/Handler/Submission.hs | 27 ++++-- src/Handler/Utils/Zip/Rating.hs | 152 ++++++++++++++++++++++++++++++-- templates/submission.hamlet | 21 +++-- 4 files changed, 183 insertions(+), 18 deletions(-) diff --git a/package.yaml b/package.yaml index 0f6d255de..718e77e3b 100644 --- a/package.yaml +++ b/package.yaml @@ -68,6 +68,7 @@ dependencies: - sandi - esqueleto - mime-types +- generic-deriving # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index cd932a393..8d0e842a1 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -12,6 +12,8 @@ module Handler.Submission where import Import +import Yesod.Form.Bootstrap3 + import Handler.Utils import Network.Mime @@ -92,22 +94,37 @@ getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html getSubmissionR = postSubmissionR postSubmissionR cID = do cIDKey <- getsYesod appCryptoIDKey - submissionID <- UUID.decrypt cIDKey cID + submissionId <- UUID.decrypt cIDKey cID + + ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,) + <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False) + <*> areq fileField (bfs ("ZIP-Archive" :: Text)) Nothing + <* bootstrapSubmit ("Upload" :: BootstrapSubmit Text) + (submission, files) <- runDB $ do - submission <- get404 (submissionID :: Key Submission) + submission <- do + submission@Submission{..} <- get404 submissionId + case uploadResult of + FormMissing -> return submission + FormFailure _ -> submission <$ setMessage "Bitte Eingabe korrigieren." + FormSuccess (isUpdate, fInfo) -> do + userId <- lift requireAuthId + submissionId' <- runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate)) + get404 submissionId' + files <- E.select . E.distinct . E.from $ \(sf `E.InnerJoin` f) -> do E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId) return (f, sf) - return $ (submission, files) + return (submission, files) let - rating@(Rating'{..}) = Rating' + Rating'{..} = Rating' { ratingPoints = submissionRatingPoints submission , ratingComment = submissionRatingComment submission , ratingTime = submissionRatingTime submission } - cID' <- Base32.encrypt cIDKey submissionID + cID' <- Base32.encrypt cIDKey submissionId let archiveBaseName = Text.unpack . CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission) archiveName = archiveBaseName <.> "zip" diff --git a/src/Handler/Utils/Zip/Rating.hs b/src/Handler/Utils/Zip/Rating.hs index 9570a9089..83480672b 100644 --- a/src/Handler/Utils/Zip/Rating.hs +++ b/src/Handler/Utils/Zip/Rating.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -20,7 +21,10 @@ module Handler.Utils.Zip.Rating , UnicodeException(..) , isRatingFile , parseRating + , SubmissionContent , extractRatings + , SubmissionSinkException(..) + , sinkSubmission ) where import Import hiding (()) @@ -29,11 +33,18 @@ import Import hiding (()) import Text.PrettyPrint.Leijen.Text hiding ((<$>)) import Control.Monad.Trans.Maybe +import Control.Monad.State import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text.Encoding.Error (UnicodeException(..)) + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Monoid (Monoid, Any(..)) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) import qualified Data.Text.Lazy.Encoding as Lazy.Text @@ -54,6 +65,8 @@ import System.FilePath import qualified Database.Esqueleto as E +import qualified Data.Conduit.List as Conduit + instance HasResolution prec => Pretty (Fixed prec) where pretty = pretty . show @@ -165,18 +178,19 @@ parseRating File{ fileContent = Just input, .. } = do parseRating _ = throwM RatingFileIsDirectory +type SubmissionContent = Either File (SubmissionId, Rating') + extractRatings :: ( MonadHandler m , HandlerSite m ~ UniWorX , MonadCatch m - ) => Conduit File m (Either File (SubmissionId, Rating')) -extractRatings = void . runMaybeT $ do - f@(File{..}) <- MaybeT await + ) => Conduit File m SubmissionContent +extractRatings = Conduit.mapM $ \f@File{..} -> do msId <- isRatingFile fileTitle - lift $ case () of + case () of _ | Just sId <- msId , isJust fileContent - -> yieldM $ Right . (sId, ) <$> parseRating f - | otherwise -> yield $ Left f + -> Right . (sId, ) <$> parseRating f + | otherwise -> return $ Left f isRatingFile :: ( MonadHandler m , HandlerSite m ~ UniWorX @@ -201,3 +215,129 @@ isRatingFile' (normalise -> fName) = Just CryptoID{..} | otherwise = Nothing + + +data SubmissionSinkState = SubmissionSinkState + { sinkSeenRating :: Any + , sinkSubmissionTouched :: Any + , sinkFilenames :: Set FilePath + } deriving (Show, Eq, Generic, Typeable) + +instance Monoid SubmissionSinkState where + mempty = memptydefault + mappend = mappenddefault + +data SubmissionSinkException = DuplicateFileTitle FilePath + | DuplicateRating + | RatingWithoutUpdate + | ForeignRating + deriving (Typeable, Show) + +instance Exception SubmissionSinkException + +sinkSubmission :: SheetId + -> UserId + -> Maybe (SubmissionId, Bool {-^ Is this a correction -}) + -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId +sinkSubmission sheetId userId mExists = do + now <- liftIO getCurrentTime + let + submissionSheetId = sheetId + submissionRatingPoints = Nothing + submissionRatingComment = Nothing + submissionRatingBy = Nothing + submissionRatingTime = Nothing + submissionCreated = now + submissionChanged = now + submissionCreatedBy = userId + submissionChangedBy = userId + + (sId, isUpdate) <- lift $ maybe ((, False) <$> insert Submission{..}) return mExists + + sId <$ sinkSubmission' sId isUpdate + where + tell = modify . mappend + + sinkSubmission' :: SubmissionId + -> Bool -- ^ Is this a correction + -> Sink SubmissionContent (YesodDB UniWorX) () + sinkSubmission' submissionId isUpdate = evalStateLC mempty . Conduit.mapM_ $ \case + Left file@(File{..}) -> do + alreadySeen <- gets (Set.member fileTitle . sinkFilenames) + when alreadySeen . throwM $ DuplicateFileTitle fileTitle + tell $ mempty{ sinkFilenames = Set.singleton fileTitle } + + collidingFiles <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do + E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId + E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId + E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate + E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work + return f + + let anyChanges + | not (null collidingFiles) = any ((/= file) . entityVal) collidingFiles + | otherwise = True + -- The Eq Instance for File compares modification time exactly even + -- though zip archives have very limited accuracy and range regarding + -- timestamps. + -- We thus expect to replace files a little more often than is actually + -- necessary. + -- This was done on the premise that changes in file modification time + -- break file identity under upload and re-download. + -- + -- We could check whether the new version of the file matches the + -- version of the file for which 'isUpdate' is different from this + -- one's, and, if so, simply delete the version for which 'isUpdate' is + -- 'True', reverting the correction. + -- + -- This idea was discarded since modification times make this difficult + -- to implement properly – should we equate file versions that differ in + -- modification time? + + when anyChanges $ do + touchSubmission + when (not $ null collidingFiles) $ + lift $ deleteCascadeWhere [ FileId <-. map entityKey collidingFiles ] + fileId <- lift $ insert file + lift . insert_ $ SubmissionFile + { submissionFileSubmissionId = submissionId + , submissionFileFileId = fileId + , submissionFileIsUpdate = isUpdate + } + Right (submissionId', Rating'{..}) -> do + unless (submissionId' == submissionId) $ throwM ForeignRating + + alreadySeen <- gets $ getAny . sinkSeenRating + when alreadySeen $ throwM DuplicateRating + tell $ mempty{ sinkSeenRating = Any True } + + unless isUpdate $ throwM RatingWithoutUpdate + + s@(Submission{..}) <- lift $ getJust submissionId + + let anyChanges = or $ + [ submissionRatingPoints /= ratingPoints + , submissionRatingComment /= ratingComment + ] + -- 'ratingTime' is ignored for consistency with 'File's: + -- + -- 'fileModified' is simply stored and never inspected while + -- 'submissionChanged' is always set to @now@. + + when anyChanges $ do + touchSubmission + lift $ update submissionId + [ SubmissionRatingPoints =. ratingPoints + , SubmissionRatingComment =. ratingComment + ] + where + touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) () + touchSubmission = do + alreadyTouched <- gets $ getAny . sinkSubmissionTouched + when (not alreadyTouched) $ do + now <- liftIO getCurrentTime + lift . update submissionId $ case isUpdate of + False -> [ SubmissionChangedBy =. userId, SubmissionChanged =. now ] + True -> [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] + tell $ mempty{ sinkSubmissionTouched = Any True } + diff --git a/templates/submission.hamlet b/templates/submission.hamlet index 38ec2baed..84d568b56 100644 --- a/templates/submission.hamlet +++ b/templates/submission.hamlet @@ -1,5 +1,5 @@ 
-  #{tshow submissionID}
+  #{tshow submissionId}
   #{tshow submission}
 
 
@@ -22,12 +22,19 @@
 
 

   

-    

-      
-