diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 97b46520e..9c706791d 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/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 diff --git a/src/Handler/Course/Events/Delete.hs b/src/Handler/Course/Events/Delete.hs index 4cad682bf..794bc0a69 100644 --- a/src/Handler/Course/Events/Delete.hs +++ b/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 diff --git a/src/Handler/Course/News/Delete.hs b/src/Handler/Course/News/Delete.hs index 88bc72d90..1b2155ee7 100644 --- a/src/Handler/Course/News/Delete.hs +++ b/src/Handler/Course/News/Delete.hs @@ -37,6 +37,9 @@ postCNDeleteR tid ssh csh cID = do drAbort, drSuccess :: SomeRoute UniWorX 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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 650d69d36..55ed2afa0 100644 --- a/src/Handler/Material.hs +++ b/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 diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 085957464..ccf3b8242 100644 --- a/src/Handler/Submission.hs +++ b/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 diff --git a/src/Handler/Tutorial/Delete.hs b/src/Handler/Tutorial/Delete.hs index 2fc9e8627..524daebe1 100644 --- a/src/Handler/Tutorial/Delete.hs +++ b/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') diff --git a/src/Handler/Utils/Course.hs b/src/Handler/Utils/Course.hs index 7f7645100..cb16f7d20 100644 --- a/src/Handler/Utils/Course.hs +++ b/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 diff --git a/src/Handler/Utils/Delete.hs b/src/Handler/Utils/Delete.hs index 291d8f34c..c77d5a10a 100644 --- a/src/Handler/Utils/Delete.hs +++ b/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' drRecords confirmString = addDeleteTargets . identifyForm FIDDelete . renderAForm FormStandard . maybe confirmFormReduced confirmForm $ assertM' (not . Text.null . Text.strip) confirmString +confirmForm' :: PersistEntity record => Set (Key record) -> Text -> Maybe Message -> Form Bool +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,29 +79,35 @@ postDeleteR :: ( DeleteCascade record SqlBackend ) postDeleteR mkRoute = do drResult <- fmap (fmap mkRoute) . runInputPost . iopt secretJsonField $ toPathPiece PostDeleteTarget - void . for drResult $ \DeleteRoute{..} -> do - 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 - + void $ traverse deleteR' drResult getDeleteR :: (DeleteCascade record SqlBackend) => DeleteRoute record -> Handler a -getDeleteR DeleteRoute{..} = do - 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)) +getDeleteR = deleteR' - 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 { formAction = Just $ SomeRoute targetRoute diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 2d4c78c0f..3dff08571 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index d9d093618..080e7f684 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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" diff --git a/src/Utils.hs b/src/Utils.hs index ddfb60acd..6b15e3fd9 100644 --- a/src/Utils.hs +++ b/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