Submission Upload

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.

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"

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'))
+                  ) => Conduit File m SubmissionContent
-extractRatings = void . runMaybeT $ do
+extractRatings = Conduit.mapM $ \f@File{..} -> do
-  f@(File{..}) <- MaybeT await
   msId <- isRatingFile fileTitle
-  lift $ case () of
+  case () of
     _ | Just sId <- msId
       , isJust fileContent
-        -> yieldM $ Right . (sId, ) <$> parseRating f
+        -> Right . (sId, ) <$> parseRating f
-      | otherwise -> yield $ Left 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 }
+

templates/submission.hamlet

@@ -1,5 +1,5 @@
 <pre style="display:none">
-  #{tshow submissionID}
+  #{tshow submissionId}
   #{tshow submission}
 
 <table .table .table-striped>
@@ -22,12 +22,19 @@
 
 <div .container-fluid>
   <div .row>
-    <div .col-md-6 .text-center style="margin-bottom:21px">
+    <div .col-md-6>
-      <a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
+      <div .panel .panel-default>
-        <span .glyphicon .glyphicon-cloud-download aria-hidden="true"> ZIP-Archive
+        <div .panel-heading>
-    <div .col-md-6 .panel .panel-default>
+          Download
-      <div .panel-body>
+        <div .panel-body .text-center>
-        Upload goes here…
+          <a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
+            <span .glyphicon .glyphicon-cloud-download aria-hidden="true"> ZIP-Archive
+    <div .col-md-6>
+      <div .panel .panel-default>
+        <div .panel-heading>
+          Replace
+        <form role=form method=post action=@{SubmissionR cID} enctype=#{uploadEnctype} .panel-body>
+          ^{uploadWidget}
   
 <div .list-group>
   $forall (Entity _ file, Entity _ sFile) <- files