From a227e21fcf67a4b9b4d4f9c67919008fd5319a61 Mon Sep 17 00:00:00 2001
From: JRoberts <8711996+jr-simplex@users.noreply.github.com>
Date: Wed, 18 Jan 2023 17:08:48 +0400
Subject: [PATCH] core: support user deletion (#1788)

* core: support user deletion

* doSendCancel

* Apply suggestions from code review

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>

* sendCancel

* refactor

* error to view

* refactor

* refactor

Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com>
---
 src/Simplex/Chat.hs            | 46 +++++++++++++++---------
 src/Simplex/Chat/Controller.hs |  2 ++
 src/Simplex/Chat/Store.hs      | 66 ++++++++++++++++------------------
 src/Simplex/Chat/View.hs       |  2 ++
 tests/ChatTests.hs             | 40 +++++++++++++++++++--
 5 files changed, 101 insertions(+), 55 deletions(-)

diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs
index 8f404d3bc1..4c43a099e2 100644
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -291,12 +291,19 @@ processChatCommand = \case
     atomically . writeTVar u $ Just user
     pure $ CRActiveUser user
   SetActiveUser uName -> withUserName uName APISetActiveUser
-  APIDeleteUser _userId -> do
-    -- prohibit to delete active user
-    -- withStore' $ \db -> deleteUser db userId
-    -- ? other cleanup
-    setActive ActiveNone
-    ok_
+  APIDeleteUser userId -> do
+    user <- withStore (`getUser` userId)
+    when (activeUser user) $ throwChatError (CECantDeleteActiveUser userId)
+    users <- withStore' getUsers
+    -- shouldn't happen - last user should be active
+    when (length users == 1) $ throwChatError (CECantDeleteLastUser userId)
+    filesInfo <- withStore' (`getUserFileInfo` user)
+    withChatLock "deleteUser" . procCmd $ do
+      forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
+      withAgent (`deleteUser` aUserId user)
+      withStore' (`deleteUserRecord` user)
+      setActive ActiveNone
+      ok_
   DeleteUser uName -> withUserName uName APIDeleteUser
   StartChat subConns enableExpireCIs -> withUser' $ \_ ->
     asks agentAsync >>= readTVarIO >>= \case
@@ -1233,7 +1240,7 @@ processChatCommand = \case
       withStore (\db -> getFileTransfer db user fileId) >>= \case
         FTSnd ftm@FileTransferMeta {cancelled} fts -> do
           unless cancelled $ do
-            cancelSndFile user ftm fts
+            cancelSndFile user ftm fts True
             sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
             withStore (\db -> getChatRefByFileId db user fileId) >>= \case
               ChatRef CTDirect contactId -> do
@@ -1552,7 +1559,10 @@ setAllExpireCIFlags b = do
     forM_ keys $ \k -> TM.insert k b expireFlags
 
 deleteFile :: forall m. ChatMonad m => User -> CIFileInfo -> m ()
-deleteFile user CIFileInfo {filePath, fileId, fileStatus} =
+deleteFile user fileInfo = deleteFile' user fileInfo False
+
+deleteFile' :: forall m. ChatMonad m => User -> CIFileInfo -> Bool -> m ()
+deleteFile' user CIFileInfo {filePath, fileId, fileStatus} sendCancel =
   (cancel' >> delete) `catchError` (toView . CRChatError (Just user))
   where
     cancel' = forM_ fileStatus $ \(AFS dir status) ->
@@ -1560,7 +1570,7 @@ deleteFile user CIFileInfo {filePath, fileId, fileStatus} =
         case dir of
           SMDSnd -> do
             (ftm@FileTransferMeta {cancelled}, fts) <- withStore (\db -> getSndFileTransfer db user fileId)
-            unless cancelled $ cancelSndFile user ftm fts
+            unless cancelled $ cancelSndFile user ftm fts sendCancel
           SMDRcv -> do
             ft@RcvFileTransfer {cancelled} <- withStore (\db -> getRcvFileTransfer db user fileId)
             unless cancelled $ cancelRcvFileTransfer user ft
@@ -2353,7 +2363,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
           withStore' $ \db -> updateSndFileChunkSent db ft msgId
           unless (fileStatus == FSCancelled) $ sendFileChunk user ft
         MERR _ err -> do
-          cancelSndFileTransfer user ft
+          cancelSndFileTransfer user ft True
           case err of
             SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
               ci <- withStore $ \db -> getChatItemByFileId db user fileId
@@ -3392,18 +3402,20 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus, rcvFileInline
       deleteAgentConnectionAsync' user connId agentConnId
     _ -> pure ()
 
-cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> m ()
-cancelSndFile user FileTransferMeta {fileId} fts = do
+cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> Bool -> m ()
+cancelSndFile user FileTransferMeta {fileId} fts sendCancel = do
   withStore' $ \db -> updateFileCancelled db user fileId CIFSSndCancelled
-  forM_ fts $ \ft' -> cancelSndFileTransfer user ft'
+  forM_ fts $ \ft' -> cancelSndFileTransfer user ft' sendCancel
 
-cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> m ()
-cancelSndFileTransfer user ft@SndFileTransfer {connId, agentConnId = agentConnId@(AgentConnId acId), fileStatus} =
+cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> Bool -> m ()
+cancelSndFileTransfer user ft@SndFileTransfer {connId, agentConnId = agentConnId@(AgentConnId acId), fileStatus} sendCancel =
   unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do
     withStore' $ \db -> do
       updateSndFileStatus db ft FSCancelled
       deleteSndFileChunks db ft
-    withAgent $ \a -> void (sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunkCancel) `catchError` \_ -> pure ()
+    when sendCancel $
+      withAgent (\a -> void (sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunkCancel))
+        `catchError` (toView . CRChatError (Just user))
     deleteAgentConnectionAsync' user connId agentConnId
 
 closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m ()
@@ -3557,7 +3569,7 @@ deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m
 deleteCIFile user file =
   forM_ file $ \CIFile {fileId, filePath, fileStatus} -> do
     let fileInfo = CIFileInfo {fileId, fileStatus = Just $ AFS msgDirection fileStatus, filePath}
-    deleteFile user fileInfo
+    deleteFile' user fileInfo True
 
 markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> m ChatResponse
 markDirectCIDeleted user ct ci@(CChatItem msgDir deletedItem) msgId byUser = do
diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs
index 65931173da..f58e7cca52 100644
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -589,6 +589,8 @@ data ChatErrorType
   | CENoConnectionUser {agentConnId :: AgentConnId}
   | CEActiveUserExists -- TODO delete
   | CEDifferentActiveUser {commandUserId :: UserId, activeUserId :: UserId}
+  | CECantDeleteActiveUser {userId :: UserId}
+  | CECantDeleteLastUser {userId :: UserId}
   | CEChatNotStarted
   | CEChatNotStopped
   | CEChatStoreChanged
diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs
index 8f9a281aa2..c99085f3bb 100644
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -30,10 +30,13 @@ module Simplex.Chat.Store
     getUsers,
     setActiveUser,
     getSetActiveUser,
+    getUser,
     getUserIdByName,
     getUserByAConnId,
     getUserByContactId,
     getUserByGroupId,
+    getUserFileInfo,
+    deleteUserRecord,
     createDirectConnection,
     createConnReqConnection,
     getProfileById,
@@ -487,10 +490,10 @@ setActiveUser db userId = do
 getSetActiveUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
 getSetActiveUser db userId = do
   liftIO $ setActiveUser db userId
-  getUser_ db userId
+  getUser db userId
 
-getUser_ :: DB.Connection -> UserId -> ExceptT StoreError IO User
-getUser_ db userId =
+getUser :: DB.Connection -> UserId -> ExceptT StoreError IO User
+getUser db userId =
   ExceptT . firstRow toUser (SEUserNotFound userId) $
     DB.query db (userQuery <> " WHERE u.user_id = ?") (Only userId)
 
@@ -519,6 +522,26 @@ getUserByFileId db fileId =
   ExceptT . firstRow toUser (SEUserNotFoundByFileId fileId) $
     DB.query db (userQuery <> " JOIN files f ON f.user_id = u.user_id WHERE f.file_id = ?") (Only fileId)
 
+getUserFileInfo :: DB.Connection -> User -> IO [CIFileInfo]
+getUserFileInfo db User {userId} =
+  map toFileInfo
+    <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId)
+
+fileInfoQuery :: Query
+fileInfoQuery =
+  [sql|
+    SELECT f.file_id, f.ci_file_status, f.file_path
+    FROM chat_items i
+    JOIN files f ON f.chat_item_id = i.chat_item_id
+  |]
+
+toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
+toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath}
+
+deleteUserRecord :: DB.Connection -> User -> IO ()
+deleteUserRecord db User {userId} =
+  DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
+
 createConnReqConnection :: DB.Connection -> UserId -> ConnId -> ConnReqUriHash -> XContactId -> Maybe Profile -> Maybe GroupLinkId -> IO PendingContactConnection
 createConnReqConnection db userId acId cReqHash xContactId incognitoProfile groupLinkId = do
   createdAt <- getCurrentTime
@@ -3031,18 +3054,7 @@ getFileTransferMeta db User {userId} fileId =
 getContactFileInfo :: DB.Connection -> User -> Contact -> IO [CIFileInfo]
 getContactFileInfo db User {userId} Contact {contactId} =
   map toFileInfo
-    <$> DB.query
-      db
-      [sql|
-        SELECT f.file_id, f.ci_file_status, f.file_path
-        FROM chat_items i
-        JOIN files f ON f.chat_item_id = i.chat_item_id
-        WHERE i.user_id = ? AND i.contact_id = ?
-      |]
-      (userId, contactId)
-
-toFileInfo :: (Int64, Maybe ACIFileStatus, Maybe FilePath) -> CIFileInfo
-toFileInfo (fileId, fileStatus, filePath) = CIFileInfo {fileId, fileStatus, filePath}
+    <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ?") (userId, contactId)
 
 deleteContactCIs :: DB.Connection -> User -> Contact -> IO ()
 deleteContactCIs db user@User {userId} ct@Contact {contactId} = do
@@ -3059,15 +3071,7 @@ getContactConnIds_ db User {userId} Contact {contactId} =
 getGroupFileInfo :: DB.Connection -> User -> GroupInfo -> IO [CIFileInfo]
 getGroupFileInfo db User {userId} GroupInfo {groupId} =
   map toFileInfo
-    <$> DB.query
-      db
-      [sql|
-        SELECT f.file_id, f.ci_file_status, f.file_path
-        FROM chat_items i
-        JOIN files f ON f.chat_item_id = i.chat_item_id
-        WHERE i.user_id = ? AND i.group_id = ?
-      |]
-      (userId, groupId)
+    <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId)
 
 deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO ()
 deleteGroupCIs db User {userId} GroupInfo {groupId} = do
@@ -4742,12 +4746,7 @@ getContactExpiredFileInfo db User {userId} Contact {contactId} expirationDate =
   map toFileInfo
     <$> DB.query
       db
-      [sql|
-        SELECT f.file_id, f.ci_file_status, f.file_path
-        FROM chat_items i
-        JOIN files f ON f.chat_item_id = i.chat_item_id
-        WHERE i.user_id = ? AND i.contact_id = ? AND i.created_at <= ?
-      |]
+      (fileInfoQuery <> " WHERE i.user_id = ? AND i.contact_id = ? AND i.created_at <= ?")
       (userId, contactId, expirationDate)
 
 deleteContactExpiredCIs :: DB.Connection -> User -> Contact -> UTCTime -> IO ()
@@ -4762,12 +4761,7 @@ getGroupExpiredFileInfo db User {userId} GroupInfo {groupId} expirationDate crea
   map toFileInfo
     <$> DB.query
       db
-      [sql|
-        SELECT f.file_id, f.ci_file_status, f.file_path
-        FROM chat_items i
-        JOIN files f ON f.chat_item_id = i.chat_item_id
-        WHERE i.user_id = ? AND i.group_id = ? AND i.item_ts <= ? AND i.created_at <= ?
-      |]
+      (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ? AND i.item_ts <= ? AND i.created_at <= ?")
       (userId, groupId, expirationDate, createdAtCutoff)
 
 deleteGroupExpiredCIs :: DB.Connection -> User -> GroupInfo -> UTCTime -> UTCTime -> IO ()
diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs
index 2d1fc9443f..0070e5b907 100644
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -1168,6 +1168,8 @@ viewChatError logLevel = \case
     CENoConnectionUser _agentConnId -> [] -- ["error: connection has no user, conn id: " <> sShow agentConnId]
     CEActiveUserExists -> ["error: active user already exists"]
     CEDifferentActiveUser commandUserId activeUserId -> ["error: different active user, command user id: " <> sShow commandUserId <> ", active user id: " <> sShow activeUserId]
+    CECantDeleteActiveUser _ -> ["cannot delete active user"]
+    CECantDeleteLastUser _ -> ["cannot delete last user"]
     CEChatNotStarted -> ["error: chat not started"]
     CEChatNotStopped -> ["error: chat not stopped"]
     CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs
index aba627a458..0b7a6d846b 100644
--- a/tests/ChatTests.hs
+++ b/tests/ChatTests.hs
@@ -177,6 +177,7 @@ chatTests = do
   describe "multiple users" $ do
     it "create second user" testCreateSecondUser
     it "both users have contact link" testMultipleUserAddresses
+    it "delete user" testDeleteUser
   describe "chat item expiration" $ do
     it "set chat item TTL" testSetChatItemTTL
   describe "queue rotation" $ do
@@ -2357,9 +2358,8 @@ testFilesFoldersImageSndDelete =
       checkActionDeletesFile "./tests/tmp/alice_app_files/test_1MB.pdf" $ do
         alice ##> "/d bob"
         alice <## "bob: contact is deleted"
-        bob <## "alice cancelled sending file 1 (test_1MB.pdf)"
         bob ##> "/fs 1"
-        bob <## "receiving file 1 (test_1MB.pdf) cancelled, received part path: test_1MB.pdf"
+        bob <##. "receiving file 1 (test_1MB.pdf) progress"
       -- deleting contact should remove cancelled file
       checkActionDeletesFile "./tests/tmp/bob_app_files/test_1MB.pdf" $ do
         bob ##> "/d alice"
@@ -4511,6 +4511,42 @@ testMultipleUserAddresses =
       showActiveUser alice "alice (Alice)"
       alice @@@ [("@bob", "hey alice")]
 
+testDeleteUser :: IO ()
+testDeleteUser =
+  testChat3 aliceProfile bobProfile cathProfile $
+    \alice bob cath -> do
+      connectUsers alice bob
+
+      alice ##> "/_delete user 1"
+      alice <## "cannot delete active user"
+
+      alice ##> "/create user alisa"
+      showActiveUser alice "alisa"
+
+      connectUsers alice cath
+
+      alice ##> "/users"
+      alice <## "alice (Alice)"
+      alice <## "alisa (active)"
+
+      alice ##> "/delete user alice"
+      alice <## "ok"
+
+      alice ##> "/users"
+      alice <## "alisa (active)"
+
+      bob #> "@alice hey"
+      -- bob <## "[alice, contactId: 2, connId: 1] error: connection authorization failed - this could happen if connection was deleted, secured with different credentials, or due to a bug - please re-create the connection"
+      (alice </)
+
+      alice ##> "/delete user alisa"
+      alice <## "cannot delete active user"
+
+      alice ##> "/users"
+      alice <## "alisa (active)"
+
+      alice <##> cath
+
 testSetChatItemTTL :: IO ()
 testSetChatItemTTL =
   testChat2 aliceProfile bobProfile $