User deletion implemented, but not tested

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
 
 
 

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)

templates/deletedUser.hamlet

@@ -0,0 +1,11 @@
+<div .container>
+  <h1>
+    Account für ^{nameWidget userDisplayName userSurname} wurde gelöscht
+  <div .container>
+    #{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht.
+  <div .container>
+    #{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank,
+    aber die Zuordnung zum Benutzer wurden gelöscht.
+    Gruppenabgaben können dadurch zu Einzelabgaben werden,
+    welche dann vom letzten Benutzer gelöscht werden können.
+