feat(submission): warn about deleting co-submissions

messages/uniworx/de-de-formal.msg

@@ -344,6 +344,8 @@ NoOpenSubmissions: Keine unkorrigierten Abgaben vorhanden
 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"}
 
+SubmissionDeleteCosubmittorsWarning n@Int: Bei #{pluralDE n "der oben aufgeführte Abgabe" "einer der oben aufgeführten Abgaben"} gibt es, außer Ihnen, noch weitere Mitabgeber. Stellen Sie sicher, dass sie Abgaben nur in Absprache mit Ihren Mitabgebern löschen oder verlassen Sie die Abgabe, indem Sie sich selbst aus der Liste der Abgebenden entfernen!
+
 SubmissionGroupName: Gruppenname
 
 CorrectionsTitle: Zugewiesene Korrekturen

src/Handler/Course/Events/Delete.hs

@@ -43,6 +43,9 @@ postCEvDeleteR tid ssh csh cID = do
     drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|event-#{toPathPiece cID}|]
     drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
   
+    drFormMessage :: [Entity CourseEvent] -> DB (Maybe Message)
+    drFormMessage _ = return Nothing
+  
     drDelete :: forall a. CourseEventId -> DB a -> DB a
     drDelete _ = id
   

src/Handler/Course/News/Delete.hs

@@ -38,6 +38,9 @@ postCNDeleteR tid ssh csh cID = do
     drAbort = SomeRoute $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
     drSuccess = SomeRoute $ CourseR tid ssh csh CShowR
 
+    drFormMessage :: [Entity CourseNews] -> DB (Maybe Message)
+    drFormMessage _ = return Nothing
+  
     drDelete :: forall a. CourseNewsId -> DB a -> DB a
     drDelete _ = id
   

src/Handler/Material.hs

@@ -351,6 +351,7 @@ postMDelR tid ssh csh mnm = do
         return $ [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{materialName}|] <> bool mempty [st| + #{tshow fileCount} Files|] (fileCount /= 0)
     , drCaption        = SomeMessage   MsgMaterialDeleteCaption
     , drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
+    , drFormMessage = const $ return Nothing
     , drSuccess = SomeRoute $ CourseR tid ssh csh   MaterialListR
     , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
     , drDelete  = const id  -- TODO: audit 

src/Handler/Submission.hs

@@ -519,7 +519,12 @@ submissionHelper tid ssh csh shn mcid = do
       _other -> return Nothing
 
   case mCID of
-    Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+    Just cID -> do
+      let showRoute  = CSubmissionR tid ssh csh shn cID SubShowR
+      mayShow <- hasReadAccessTo showRoute
+      if
+        | mayShow   -> redirect showRoute
+        | otherwise -> redirect $ CSheetR tid ssh csh shn SShowR
     Nothing  -> return ()
 
   -- Maybe construct a table to display uploaded archive files

src/Handler/Tutorial/Delete.hs

@@ -32,6 +32,7 @@ postTDeleteR tid ssh csh tutn = do
         return [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{tutorialName}+#{tshow ps}|]
     , drCaption = SomeMessage MsgTutorialDeleteQuestion
     , drSuccessMessage = SomeMessage MsgTutorialDeleted
+    , drFormMessage = const $ return Nothing
     , drAbort = SomeRoute $ CTutorialR tid ssh csh tutn TUsersR
     , drSuccess = SomeRoute $ CourseR tid ssh csh CTutorialListR
     , drDelete = \tutid' act -> act <* audit (TransactionTutorialDelete tutid')

src/Handler/Utils/Course.hs

@@ -22,6 +22,7 @@ courseDeleteRoute drRecords = DeleteRoute
       return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{cName}|]
   , drCaption = SomeMessage MsgCourseDeleteQuestion
   , drSuccessMessage = SomeMessage MsgCourseDeleted
+  , drFormMessage = const $ return Nothing
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
   , drDelete = const id  -- TODO: audit

src/Handler/Utils/Delete.hs

@@ -35,6 +35,7 @@ data DeleteRoute record = forall tables infoExpr info. (E.SqlSelect infoExpr inf
   , drUnjoin :: tables -> E.SqlExpr (Entity record) -- ^ `E.SqlExpr` of @Key record@ extracted from @tables@, `deleteR` restricts `drGetInfo` to `drRecords` automatically
   , drRenderRecord :: info -> DB Widget -- ^ Present a single record, to be deleted, to the user for inspection prior to deletion
   , drRecordConfirmString :: info -> DB Text -- ^ Text for the user to copy to confirm deletion; should probably contain all information from `drRenderRecord` so user gets prompted to think about what they're deleting
+  , drFormMessage :: [info] -> DB (Maybe Message)
   , drCaption
   , drSuccessMessage :: SomeMessage UniWorX
   , drAbort
@@ -62,8 +63,8 @@ confirmForm confirmString = flip traverseAForm aform $ \(inpConfirmStr, BtnDelet
 confirmFormReduced :: Monad m => AForm m Bool
 confirmFormReduced = pure True
 
-confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Form Bool
+confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Maybe Message -> Form Bool
-confirmForm' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString
+confirmForm' drRecords confirmString mmsg = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe id ((*>) . aformMessage) mmsg . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString
   where
     addDeleteTargets :: Form a -> Form a
     addDeleteTargets form csrf = do
@@ -78,28 +79,34 @@ postDeleteR :: ( DeleteCascade record SqlBackend )
 postDeleteR mkRoute = do
   drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget
 
-  void . for drResult $ \DeleteRoute{..} -> do
+  void $ traverse deleteR' drResult
-    confirmString <- fmap Text.unlines . runDB $ mapM drRecordConfirmString <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
-
-    ((confirmRes, _), _) <- runFormPost $ confirmForm' drRecords confirmString
-
-    formResult confirmRes $ \case
-      True -> do
-        runDB $ do
-          forM_ drRecords $ \k -> drDelete k $ deleteCascade k
-          addMessageI Success drSuccessMessage
-        redirect drSuccess
-      False ->
-        redirect drAbort
-
 
 getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
-getDeleteR DeleteRoute{..} = do
+getDeleteR = deleteR'
-  targets <- runDB $ mapM (\i -> (,) <$> drRenderRecord i <*> drRecordConfirmString i) <=< E.select . E.from $ \t -> drGetInfo t <* E.where_ (drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords))
 
-  let confirmString = Text.unlines $ view _2 <$> targets
+deleteR' :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a
+deleteR' DeleteRoute{..} = do
+  (targets, confirmString, message) <- runDB $ do
+    infos <- E.select . E.from $ \t -> do
+      E.where_ $ drUnjoin t E.^. persistIdField `E.in_` E.valList (Set.toList drRecords)
+      drGetInfo t
 
-  (deleteFormWdgt, deleteFormEnctype) <- generateFormPost $ confirmForm' drRecords confirmString
+    targets <- mapM (runKleisli $ Kleisli drRenderRecord &&& Kleisli drRecordConfirmString) infos
+    let confirmString = Text.unlines $ view _2 <$> targets
+    message <- drFormMessage infos
+
+    return (targets, confirmString, message)
+
+  ((confirmRes, deleteFormWdgt), deleteFormEnctype) <- runFormPost $ confirmForm' drRecords confirmString message
+
+  formResult confirmRes $ \case
+    True -> do
+      runDB $ do
+        forM_ drRecords $ \k -> drDelete k $ deleteCascade k
+        addMessageI Success drSuccessMessage
+      redirect drSuccess
+    False ->
+      redirect drAbort
   
   targetRoute <- fromMaybe (error "getDeleteR called from 404-handler") <$> getCurrentRoute
   let deleteForm = wrapForm' BtnDelete deleteFormWdgt def

src/Handler/Utils/Sheet.hs

@@ -74,6 +74,7 @@ sheetDeleteRoute drRecords = DeleteRoute
       return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
   , drCaption = SomeMessage MsgSheetDeleteQuestion
   , drSuccessMessage = SomeMessage MsgSheetDeleted
+  , drFormMessage = const $ return Nothing
   , drAbort = error "drAbort undefined"
   , drSuccess = error "drSuccess undefined"
   , drDelete = const id  -- TODO: audit

src/Handler/Utils/Submission.hs

@@ -744,6 +744,21 @@ submissionDeleteRoute drRecords = DeleteRoute
       subNames <- fmap sort . forM subUsers $ \(Entity _ SubmissionUser{submissionUserUser}) -> userSurname <$> getJust submissionUserUser
       let subNames' = Text.intercalate ", " subNames
       return [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}/#{subNames'}|]
+  , drFormMessage = \infos -> do
+      let
+        coSubWarning (E.Value subId, _, _, _, _, _, _) = do
+          uid <- maybeAuthId
+          subUsers <- selectList [SubmissionUserSubmission ==. subId] []
+          if
+            | length subUsers >= 1
+            , maybe False (flip any subUsers . (. submissionUserUser . entityVal) . (==)) uid
+              -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
+            | otherwise
+              -> return Nothing
+
+      coSubWarning' <- foldMapM (fmap First . coSubWarning) infos
+
+      return $ getFirst coSubWarning'
   , drCaption = SomeMessage $ MsgSubmissionsDeleteQuestion 1
   , drSuccessMessage = SomeMessage $ MsgSubmissionsDeleted 1
   , drAbort = error "drAbort undefined"

src/Utils.hs

@@ -658,6 +658,9 @@ ofoldr1M _ _ = error "otoList of NonNull is empty"
 ofoldl1M f (otoList -> x:xs) = foldlM f x xs
 ofoldl1M _ _ = error "otoList of NonNull is empty"
 
+foldMapM :: (Foldable f, Monad m, Monoid b) => (a -> m b) -> f a -> m b
+foldMapM f = foldrM (\x xs -> (<>) <$> f x <*> pure xs) mempty
+
 partitionM :: forall mono m .
   ( MonoFoldable mono
   , Monoid mono