From 38dbc0905cbacdbe87ffe40a8c4510606879f4fc Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 19 Dec 2018 22:31:09 +0100
Subject: [PATCH] Single-submission deletion

---
 messages/uniworx/de.msg         |  4 ++++
 routes                          |  3 ++-
 src/Foundation.hs               | 18 +++++++++++++++++
 src/Handler/Submission.hs       | 34 +++++++++++++++++++++++++++++++++
 src/Handler/Utils/Delete.hs     |  4 +++-
 templates/default-layout.lucius |  1 +
 6 files changed, 62 insertions(+), 2 deletions(-)

diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg
index fd07e0ad8..247b2a780 100644
--- a/messages/uniworx/de.msg
+++ b/messages/uniworx/de.msg
@@ -144,6 +144,9 @@ SubmissionFile: Datei zur Abgabe
 SubmissionFiles: Abgegebene Dateien
 SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
 
+SubmissionsDeleteQuestion count@Int: Wollen Sie #{pluralDE count "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
+SubmissionsDeleted count@Int: #{pluralDE count "Abgabe gelöscht" "Abgaben gelöscht"}
+
 SubmissionGroupName: Gruppenname
 
 CorrectionsTitle: Zugewiesene Korrekturen
@@ -536,6 +539,7 @@ MenuLogout: Logout
 MenuCourseList: Kurse
 MenuTermShow: Semester
 MenuCorrection: Korrektur
+MenuSubmissionDelete: Abgabe löschen
 MenuUsers: Benutzer
 MenuAdminTest: Admin-Demo
 MenuMessageList: Systemnachrichten
diff --git a/routes b/routes
index c2a320731..f29cc077b 100644
--- a/routes
+++ b/routes
@@ -79,8 +79,9 @@
     !/subs/new                  SubmissionNewR GET POST       !timeANDregisteredANDuser-submissions
     !/subs/own                  SubmissionOwnR GET            !free -- just redirect
     /subs/#CryptoFileNameSubmission SubmissionR:
-      /                         SubShowR      GET POST !ownerANDtime !ownerANDread !correctorANDread
+      /                         SubShowR      GET POST        !ownerANDtime !ownerANDread !correctorANDread
       /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner !corrector
+      /delete                   SubDelR       GET POST        !ownerANDtime
       /assign                   SAssignR      GET POST	      !lecturerANDtime
       /correction               CorrectionR   GET POST        !corrector !ownerANDreadANDrated
       !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner !corrector
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 9ec2efe26..b63830a54 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1310,6 +1310,24 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
       , menuItemModal = True
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuSubmissionDelete
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
+  [ MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuSubmissionDelete
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CSheetR tid ssh csh shn SCorrR) =
   [ MenuItem
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index d3641e34c..8357e4023 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -7,6 +7,7 @@ import Jobs
 -- import Yesod.Form.Bootstrap3
 
 import Handler.Utils
+import Handler.Utils.Delete
 import Handler.Utils.Submission
 import Handler.Utils.Table.Cells
 
@@ -19,6 +20,7 @@ import Network.Mime
 import Data.Monoid (Any(..))
 import Data.Maybe (fromJust)
 -- import qualified Data.Maybe
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 
 import Data.CaseInsensitive (CI)
@@ -390,3 +392,35 @@ getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
       zipComment = Text.encodeUtf8 $ toPathPiece cID
 
     fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
+
+getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSubDelR = postSubDelR
+postSubDelR tid ssh csh shn cID = do
+  subId <- runDB $ submissionMatchesSheet tid ssh csh shn cID
+  deleteR DeleteRoute
+    { drRecords = Set.singleton subId
+    , drRenderRecord = \(Entity subId' Submission{submissionSheet}) -> do
+        Sheet{sheetName, sheetCourse} <- getJust submissionSheet
+        Course{courseName, courseSchool, courseTerm} <- getJust sheetCourse
+        School{schoolName} <- getJust courseSchool
+        subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+        subNames <- fmap (sortOn snd) . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> (userDisplayName &&& userSurname) <$> getJust submissionUserUser
+        return [whamlet|
+          $newline never
+          <ul .list--comma-separated .list--inline .list--iconless>
+            $forall (dName, sName) <- subNames
+              <li>^{nameWidget dName sName}
+          &nbsp;(_{ShortTermIdentifier (unTermKey courseTerm)}, #{schoolName}, #{courseName}, #{sheetName})
+        |]
+    , drRecordConfirmString = \(Entity subId' Submission{submissionSheet}) -> do
+        Sheet{sheetName, sheetCourse} <- getJust submissionSheet
+        Course{courseShorthand, courseSchool, courseTerm} <- getJust sheetCourse
+        subUsers <- selectList [SubmissionUserSubmission ==. subId'] []
+        subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
+        let subNames' = Text.intercalate ", " subNames
+        return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{sheetName}/#{subNames'}|]
+    , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
+    , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
+    , drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
+    , drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
+    }
diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs
index 68cdb13d9..756fc5da9 100644
--- a/src/Handler/Utils/Delete.hs
+++ b/src/Handler/Utils/Delete.hs
@@ -21,6 +21,8 @@ import Crypto.Hash (Digest, SHAKE128)
 
 import qualified Data.ByteArray as ByteArray
 
+import Data.Char (isAlphaNum)
+
 
 data DeleteRoute = forall record. (DeleteCascade record SqlBackend, Hashable (Key record)) => DeleteRoute
   { drRecords :: Set (Key record)
@@ -57,7 +59,7 @@ deleteR DeleteRoute{..} = do
     (_, catMaybes -> [BtnAbort]) ->
       redirect drAbort
     (inpConfirmStr, catMaybes -> [BtnDelete])
-      | ((==) `on` map CI.mk . Text.words) confirmString inpConfirmStr
+      | ((==) `on` map (CI.mk . filter isAlphaNum) . Text.words) confirmString inpConfirmStr
         -> do
           runDB $ do
             forM_ drRecords deleteCascade
diff --git a/templates/default-layout.lucius b/templates/default-layout.lucius
index 8deb58679..8e8568687 100644
--- a/templates/default-layout.lucius
+++ b/templates/default-layout.lucius
@@ -439,6 +439,7 @@ input[type="button"].btn-info:hover,
 }
 
 .list--inline {
+  display: inline-block;
   margin-left: 0;
 
   li {