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>
2026-05-14 21:15:37 +00:00 · 2023-01-18 17:08:48 +04:00
parent 84237f79fc
commit a227e21fcf
5 changed files with 101 additions and 55 deletions
@@ -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
@@ -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
@@ -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 ()
@@ -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"]
@@ -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 $