diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 55092ff11..de1b22a7c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -163,17 +163,44 @@ postProfileDataR = do case btnResult of (FormSuccess BtnDelete) -> do (uid, User{..}) <- requireAuthPair - addMessage Warning "Delete-Knopf gedrückt" - addMessage Error "Löschen der Daten wurde noch nicht implementiert." - -- first determine all submission that solely depend on this user: - -- SubmissionGroup / SubmissionGroupUser - -- Submission / SubmissionUser - -- runDB $ deleteCascade uid + (deletedSubmissions,groupSubmissions) <- runDB $ deleteUser uid + -- addMessageI Success $ MsgDeleteUser deletedSubmissions + -- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions + --TODO: LogOut user + defaultLayout $ do + $(widgetFile "deletedUser") + (FormSuccess BtnAbort ) -> do addMessageI Info MsgAborted redirect ProfileDataR - _other -> return () - getProfileDataR + _other -> getProfileDataR + + + +deleteUser :: UserId -> DB (Int,Int) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration +deleteUser duid = do + -- E.deleteCount for submissions is not cascading, hence we first select and then delete manually + -- Submissions / SubmissionUser + -- TODO: SubmissionGroup / SubmissionGroupUser + -- TODO: SheetPseudonym ??? + groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64)) + singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64)) + deleteCascade duid + forM_ singleSubmissions $ \(E.Value submissionId) -> deleteCascade submissionId + return (length singleSubmissions, length groupSubmissions) + where + selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) + -> ReaderT SqlBackend (HandlerT UniWorX IO) [E.Value (Key Submission)] + selectSubmissionsWhere whereBuddies = + E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do + E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission + let numBuddies = E.sub_select $ E.from $ \subUsers -> do + E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId + E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid + return E.countRows + E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid + E.&&. (whereBuddies numBuddies) + return $ submission E.^. SubmissionId diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index 380bb8b2a..69d230275 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -15,7 +15,7 @@ import qualified Data.Set as Set import qualified Database.Esqueleto as E -- import Database.Persist -- currently not needed here - +-- ezero = E.val (0 :: Int64) emptyOrIn :: PersistField typ => E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool) diff --git a/templates/deletedUser.hamlet b/templates/deletedUser.hamlet new file mode 100644 index 000000000..04336132f --- /dev/null +++ b/templates/deletedUser.hamlet @@ -0,0 +1,11 @@ +