feat(submissions): warn about multiple submissions for same user

frontend/src/app.sass

@@ -403,6 +403,9 @@ input[type="button"].btn-info:not(.btn-link):hover,
     font-weight: 600
     color: var(--color-fontsec)
 
+.table__td--tooltip
+  width: 2em
+
 .table__td
   font-size: 16px
   color: var(--color-font)

messages/uniworx/misc/de-de-formal.msg

@@ -404,6 +404,8 @@ SubmissionFilesCorrected: Abgegebene & Korrigierte Dateien
 RatingUpdatedFiles: Bei der Korrektur wurden Dateien angepasst oder hinzugefügt
 SubmissionFilesUnchanged: Abgabedateien beibehalten
 SubmissionFilesUnchangedTip: Sollen die bestehenden Abgabedateien beim Ersetzen der Abgabe unverändert übernommen werden?
+SubmissionUserDuplicateWarning: Dieser Teilnehmende ist bereits an einer anderen Abgabe beteiligt
+SubmissionSomeUsersDuplicateWarning: Manche Abgebende sind auch an einer anderen Abgabe beteiligt
 
 SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
 SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}

messages/uniworx/misc/en-eu.msg

@@ -402,6 +402,8 @@ SubmissionFilesCorrected: Submitted & Corrected files
 RatingUpdatedFiles: During correction files were added or changed
 SubmissionFilesUnchanged: Keep submission files
 SubmissionFilesUnchangedTip: Should the existing submission files be retained unchanged while replacing the submission?
+SubmissionUserDuplicateWarning: This participant is already a submittor for a different submission
+SubmissionSomeUsersDuplicateWarning: Some submittors are also submittors for a different submission
 
 SubmissionsDeleteQuestion n: Do you really want to delete the #{pluralEN n "submission" "submissions"} mentioned below?
 SubmissionsDeleted n: #{pluralEN n "Submission" "Submissions"} deleted

src/Handler/Submission/Helper.hs

@@ -32,8 +32,8 @@ import Handler.Submission.SubmissionUserInvite
 import qualified Data.Conduit.Combinators as C
 
 
-makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
-makeSubmissionForm cid msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
+makeSubmissionForm :: CourseId -> SheetId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Maybe FileUploads -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
+makeSubmissionForm cid shid msmid uploadMode grouping mPrev isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
   <$> uploadForm
   <*> wFormToAForm submittorsForm'
   where
@@ -51,7 +51,17 @@ makeSubmissionForm cid msmid uploadMode grouping mPrev isLecturer prefillUsers =
         | otherwise  -> MsgEmailInvitationWarningPrevCoSubmittors
       $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
     miCell' csrf (Right uid) = do
-      User{..} <- liftHandler . runDB $ getJust uid
+      (User{..}, hasSubmitted) <- liftHandler . runDB $ do
+        user <- getJust uid
+        hasSubmitted <- E.selectExists . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+          E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+          E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
+               E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+          whenIsJust msmid $ \smid -> 
+            E.where_ $ submission E.^. SubmissionId E.!=. E.val smid
+        return (user, hasSubmitted)
+      knownWarning <- runMaybeT $
+        guardOnM hasSubmitted $ messageIconI Error IconSubmissionUserDuplicate MsgSubmissionUserDuplicateWarning
       $(widgetFile "widgets/massinput/submissionUsers/cellKnown")
 
     miLayout :: ListLength
@@ -319,9 +329,9 @@ submissionHelper tid ssh csh shn mcid = do
   -- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
   -- Therefore we do not restrict upload behaviour in any way in that case
   ((res,formWidget'), formEnctype) <- do
-    (Entity _ Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
+    (Entity shid Sheet{..}, buddies, _, _, isLecturer, isOwner, _, _) <- runDB getSheetInfo
     let mPrevUploads = msmid <&> \smid -> runDBSource $ selectSource [SubmissionFileSubmission ==. smid, SubmissionFileIsUpdate ==. False] [Asc SubmissionFileTitle] .| C.map (view $ _FileReference . _1)
-    runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
+    runFormPost . makeSubmissionForm sheetCourse shid msmid (fromMaybe (UploadAny True Nothing True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping mPrevUploads isLecturer $ bool id (maybe id (Set.insert . Right) muid) isOwner buddies
   let formWidget = wrapForm' BtnHandIn formWidget' def
         { formAction = Just $ SomeRoute actionUrl
         , formEncoding = formEnctype
@@ -360,6 +370,7 @@ submissionHelper tid ssh csh shn mcid = do
       (FormFailure failmsgs)   -> return $ FormFailure failmsgs
       (FormSuccess res'@(_, groupMembers))
         | groupMembers == subUsersOld -> return $ FormSuccess res'
+        | isLecturer -> return $ FormSuccess res'
         | Arbitrary{..} <- sheetGrouping -> do -- Validate AdHoc Group Members
           let (gEMails, gIds) = partitionEithers $ Set.toList groupMembers
               prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map UserEmail (Maybe (UserId, Bool, Bool))
@@ -486,7 +497,7 @@ submissionHelper tid ssh csh shn mcid = do
         | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
     Nothing  -> return ()
 
-  (Entity _ Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
+  (Entity shid Sheet{..}, _, lastEdits, maySubmit, _, _, msubmission, corrector) <- runDB getSheetInfo
 
   (showCorrection, correctionInvisible) <- fmap (fromMaybe (False, Nothing)) . for ((,) <$> mcid <*> (Entity <$> msmid <*> msubmission)) $ \(cid, subEnt) -> runDB $ do
     showCorrection <- hasReadAccessTo $ CSubmissionR tid ssh csh shn cid CorrectionR
@@ -565,6 +576,22 @@ submissionHelper tid ssh csh shn mcid = do
 
   sheetTypeDesc <- liftHandler . runDB $ sheetTypeDescription sheetCourse sheetType
 
+  multipleSubmissionWarnWidget <- runDB . runMaybeT $ do
+    subId <- hoistMaybe msmid
+    cID <- hoistMaybe mcid
+    guardM . lift $ orM
+      [ hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubDelR
+      , hasWriteAccessTo $ CSubmissionR tid ssh csh shn cID SubShowR
+      ]
+    guardM . lift . E.selectExists . E.from $ \(submissionUser `E.InnerJoin` (otherSubmissionUser `E.InnerJoin` submission)) -> do
+      E.on $ otherSubmissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+      E.on $ submissionUser E.^. SubmissionUserSubmission E.!=. otherSubmissionUser E.^. SubmissionUserSubmission
+       E.&&. submissionUser E.^. SubmissionUserUser E.==. otherSubmissionUser E.^. SubmissionUserUser
+      E.where_ $ submission E.^. SubmissionSheet E.==. E.val shid
+           E.&&. submission E.^. SubmissionId E.!=. E.val subId
+           E.&&. submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
+    return $ notification NotificationBroad =<< messageIconI Warning IconSubmissionUserDuplicate MsgSubmissionSomeUsersDuplicateWarning
+
   defaultLayout $ do
     setTitleI $ MsgSubmissionEditHead tid ssh csh shn
     (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID

src/Utils/Icon.hs

@@ -92,6 +92,7 @@ data Icon
   | IconPersonalIdentification
   | IconMenuWorkflows
   | IconVideo
+  | IconSubmissionUserDuplicate
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
 
 iconText :: Icon -> Text
@@ -164,6 +165,7 @@ iconText = \case
     IconPersonalIdentification  -> "id-card"
     IconMenuWorkflows           -> "project-diagram"
     IconVideo                   -> "video"
+    IconSubmissionUserDuplicate -> "copy"
 
 instance Universe Icon
 instance Finite   Icon

templates/submission.hamlet

@@ -8,6 +8,8 @@ $if is _Just mcid
         ^{warning}
 
       ^{wdgt}
+
+  ^{maybeVoid multipleSubmissionWarnWidget}
   
   <section>
     $case sheetSubmissionMode

templates/widgets/massinput/examCorrectors/cellInvitation.hamlet

@@ -2,5 +2,5 @@ $newline never
 <td>
   <span .email>
     #{email}
-<td>
+<td .table__td--tooltip>
   ^{messageTooltip invWarnMsg}

templates/widgets/massinput/examOfficeUsers/cellInvitation.hamlet

@@ -2,5 +2,5 @@
  <td>
    <span .email>
      #{email}
- <td>
+ <td .table__td--tooltip>
    ^{messageTooltip invWarnMsg}

templates/widgets/massinput/submissionUsers/cellInvitation.hamlet

@@ -3,5 +3,5 @@
    #{csrf}
    <span .email>
      #{email}
- <td>
+ <td .table__td--tooltip>
    ^{messageTooltip invWarnMsg}

templates/widgets/massinput/submissionUsers/cellKnown.hamlet

@@ -1,4 +1,11 @@
 $newline never
-<td colspan=2>
-  #{csrf}
-  ^{nameEmailWidget userEmail userDisplayName userSurname}
+$maybe wrn <- knownWarning
+ <td>
+   #{csrf}
+   ^{nameEmailWidget userEmail userDisplayName userSurname}
+ <td .table__td--tooltip>
+   ^{messageTooltip wrn}
+$nothing
+  <td colspan=2>
+    #{csrf}
+    ^{nameEmailWidget userEmail userDisplayName userSurname}