core: delete connections asynchronously (#1151)

2026-03-31 01:05:55 +00:00 · 2022-09-30 16:18:43 +04:00
parent dd5e99ea42
commit 428d3cdba5
6 changed files with 120 additions and 46 deletions
--- a/cabal.project
+++ b/cabal.project
@@ -7,7 +7,7 @@ constraints: zip +disable-bzip2 +disable-zstd
 source-repository-package
    type: git
    location: https://github.com/simplex-chat/simplexmq.git
-    tag: 413aad5139acee28033404aed2e5516fc71c337c
+    tag: a2eea4f18f61a954daf1aa0559c0acf0ef0b1bd2

 source-repository-package
    type: git
--- a/scripts/nix/sha256map.nix
+++ b/scripts/nix/sha256map.nix
@@ -1,5 +1,5 @@
 {
-  "https://github.com/simplex-chat/simplexmq.git"."413aad5139acee28033404aed2e5516fc71c337c" = "0vzmglhnbr2x9frs597sg6v8if1hfydbmnza5532sc486qms0vmg";
+  "https://github.com/simplex-chat/simplexmq.git"."a2eea4f18f61a954daf1aa0559c0acf0ef0b1bd2" = "0s7pkqgfcs9z4rmv533pnxr60xpqgg4aqkkizbn7icn4a6jiwl6y";
  "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
  "https://github.com/simplex-chat/sqlcipher-simple.git"."5e154a2aeccc33ead6c243ec07195ab673137221" = "1d1gc5wax4vqg0801ajsmx1sbwvd9y7p7b8mmskvqsmpbwgbh0m0";
  "https://github.com/simplex-chat/aeson.git"."3eb66f9a68f103b5f1489382aad89f5712a64db7" = "0kilkx59fl6c3qy3kjczqvm8c3f4n3p0bdk9biyflf51ljnzp4yp";
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -468,8 +468,7 @@ processChatCommand = \case
            forM_ filesInfo $ \fileInfo -> do
              cancelFile user fileInfo `catchError` \_ -> pure ()
              withFilesFolder $ \filesFolder -> deleteFile filesFolder fileInfo
-            withAgent $ \a -> forM_ conns $ \conn ->
-              deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure ()
+            forM_ conns $ \conn -> deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
            -- functions below are called in separate transactions to prevent crashes on android
            -- (possibly, race condition on integrity check?)
            withStore' $ \db -> deleteContactConnectionsAndFiles db userId ct
@@ -478,8 +477,8 @@ processChatCommand = \case
            pure $ CRContactDeleted ct
        gs -> throwChatError $ CEContactGroups ct gs
    CTContactConnection -> withChatLock . procCmd $ do
-      conn <- withStore $ \db -> getPendingContactConnection db userId chatId
-      withAgent $ \a -> deleteConnection a $ aConnId' conn
+      conn@PendingContactConnection {pccConnId, pccAgentConnId} <- withStore $ \db -> getPendingContactConnection db userId chatId
+      deleteAgentConnectionAsync' user pccConnId pccAgentConnId
      withStore' $ \db -> deletePendingContactConnection db userId chatId
      pure $ CRContactConnectionDeleted conn
    CTGroup -> do
@@ -489,7 +488,7 @@ processChatCommand = \case
      void $ clearGroupContent user gInfo
      withChatLock . procCmd $ do
        when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel
-        mapM_ deleteMemberConnection members
+        forM_ members $ deleteMemberConnection user
        -- functions below are called in separate transactions to prevent crashes on android
        -- (possibly, race condition on integrity check?)
        withStore' $ \db -> deleteGroupConnectionsAndFiles db user gInfo members
@@ -737,8 +736,7 @@ processChatCommand = \case
  DeleteMyAddress -> withUser $ \user -> withChatLock $ do
    conns <- withStore (`getUserContactLinkConnections` user)
    procCmd $ do
-      withAgent $ \a -> forM_ conns $ \conn ->
-        deleteConnection a (aConnId conn) `catchError` \(_ :: AgentErrorType) -> pure ()
+      forM_ conns $ \conn -> deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
      withStore' (`deleteUserContactLink` user)
      pure CRUserContactLinkDeleted
  ShowMyAddress -> withUser $ \User {userId} ->
@@ -849,13 +847,13 @@ processChatCommand = \case
        withChatLock . procCmd $ do
          case mStatus of
            GSMemInvited -> do
-              deleteMemberConnection m
+              deleteMemberConnection user m
              withStore' $ \db -> deleteGroupMember db user m
            _ -> do
              msg <- sendGroupMessage gInfo members $ XGrpMemDel mId
              ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) Nothing Nothing
              toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
-              deleteMemberConnection m
+              deleteMemberConnection user m
              withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved
          pure $ CRUserDeletedMember gInfo m {memberStatus = GSMemRemoved}
  APILeaveGroup groupId -> withUser $ \user@User {userId} -> do
@@ -865,7 +863,7 @@ processChatCommand = \case
      ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) Nothing Nothing
      toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
      -- TODO delete direct connections that were unused
-      mapM_ deleteMemberConnection members
+      forM_ members $ deleteMemberConnection user
      withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
      pure $ CRLeftMemberUser gInfo {membership = membership {memberStatus = GSMemLeft}}
  APIListMembers groupId -> CRGroupMembers <$> withUser (\user -> withStore (\db -> getGroup db user groupId))
@@ -1744,7 +1742,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
          withStore' $ \db -> updateSndFileChunkSent db ft msgId
          unless (fileStatus == FSCancelled) $ sendFileChunk user ft
        MERR _ err -> do
-          cancelSndFileTransfer ft
+          cancelSndFileTransfer user ft
          case err of
            SMP SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
              ci <- withStore $ \db -> getChatItemByFileId db user fileId
@@ -1811,7 +1809,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
                          getChatItemByFileId db user fileId
                        toView $ CRRcvFileComplete ci
                        closeFileHandle fileId rcvFiles
-                        withAgent (`deleteConnection` agentConnId)
+                        deleteAgentConnectionAsync user conn
                  RcvChunkDuplicate -> pure ()
                  RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
        OK ->
@@ -2350,7 +2348,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
      members <- withStore' $ \db -> getGroupMembers db user gInfo
      if memberId (membership :: GroupMember) == memId
        then do
-          mapM_ deleteMemberConnection members
+          forM_ members $ deleteMemberConnection user
          withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved
          ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEUserDeleted) Nothing
          groupMsgToView gInfo m ci msgMeta
@@ -2362,7 +2360,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
            if mRole < GRAdmin || mRole < memberRole (member :: GroupMember)
              then messageError "x.grp.mem.del with insufficient member permissions"
              else do
-                deleteMemberConnection member
+                deleteMemberConnection user member
                withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved
                ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)) Nothing
                groupMsgToView gInfo m ci msgMeta
@@ -2373,7 +2371,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM

    xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m ()
    xGrpLeave gInfo m msg msgMeta = do
-      deleteMemberConnection m
+      deleteMemberConnection user m
      withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
      ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) Nothing
      groupMsgToView gInfo m ci msgMeta
@@ -2386,7 +2384,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
        members <- getGroupMembers db user gInfo
        updateGroupMemberStatus db userId membership GSMemGroupDeleted
        pure members
-      mapM_ deleteMemberConnection ms
+      forM_ ms $ deleteMemberConnection user
      ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted) Nothing
      groupMsgToView gInfo m ci msgMeta
      toView $ CRGroupDeleted gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
@@ -2404,7 +2402,7 @@ parseChatMessage :: ByteString -> Either ChatError ChatMessage
 parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode

 sendFileChunk :: ChatMonad m => User -> SndFileTransfer -> m ()
-sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentConnId acId} =
+sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, connId, agentConnId} =
  unless (fileStatus == FSComplete || fileStatus == FSCancelled) $
    withStore' (`createSndFileChunk` ft) >>= \case
      Just chunkNo -> sendFileChunkNo ft chunkNo
@@ -2415,7 +2413,7 @@ sendFileChunk user ft@SndFileTransfer {fileId, fileStatus, agentConnId = AgentCo
          updateDirectCIFileStatus db user fileId CIFSSndComplete
        toView $ CRSndFileComplete ci ft
        closeFileHandle fileId sndFiles
-        withAgent (`deleteConnection` acId)
+        deleteAgentConnectionAsync' user connId agentConnId

 sendFileChunkNo :: ChatMonad m => SndFileTransfer -> Integer -> m ()
 sendFileChunkNo ft@SndFileTransfer {agentConnId = AgentConnId acId} chunkNo = do
@@ -2496,26 +2494,25 @@ cancelRcvFileTransfer user ft@RcvFileTransfer {fileId, fileStatus} = do
    updateRcvFileStatus db ft FSCancelled
    deleteRcvFileChunks db ft
  case fileStatus of
-    RFSAccepted RcvFileInfo {agentConnId = AgentConnId acId} ->
-      withAgent (`deleteConnection` acId)
-    RFSConnected RcvFileInfo {agentConnId = AgentConnId acId} ->
-      withAgent (`deleteConnection` acId)
+    RFSAccepted RcvFileInfo {connId, agentConnId} ->
+      deleteAgentConnectionAsync' user connId agentConnId
+    RFSConnected RcvFileInfo {connId, agentConnId} ->
+      deleteAgentConnectionAsync' user connId agentConnId
    _ -> pure ()

 cancelSndFile :: ChatMonad m => User -> FileTransferMeta -> [SndFileTransfer] -> m ()
 cancelSndFile user FileTransferMeta {fileId} fts = do
  withStore' $ \db -> updateFileCancelled db user fileId CIFSSndCancelled
-  forM_ fts $ \ft' -> cancelSndFileTransfer ft'
+  forM_ fts $ \ft' -> cancelSndFileTransfer user ft'

-cancelSndFileTransfer :: ChatMonad m => SndFileTransfer -> m ()
-cancelSndFileTransfer ft@SndFileTransfer {agentConnId = AgentConnId acId, fileStatus} =
+cancelSndFileTransfer :: ChatMonad m => User -> SndFileTransfer -> m ()
+cancelSndFileTransfer user ft@SndFileTransfer {connId, agentConnId = agentConnId@(AgentConnId acId), fileStatus} =
  unless (fileStatus == FSCancelled || fileStatus == FSComplete) $ do
    withStore' $ \db -> do
      updateSndFileStatus db ft FSCancelled
      deleteSndFileChunks db ft
-    withAgent $ \a -> do
-      void (sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunkCancel) `catchError` \_ -> pure ()
-      deleteConnection a acId
+    withAgent $ \a -> void (sendMessage a acId SMP.noMsgFlags $ smpEncode FileChunkCancel) `catchError` \_ -> pure ()
+    deleteAgentConnectionAsync' user connId agentConnId

 closeFileHandle :: ChatMonad m => Int64 -> (ChatController -> TVar (Map Int64 Handle)) -> m ()
 closeFileHandle fileId files = do
@@ -2526,12 +2523,12 @@ closeFileHandle fileId files = do
 throwChatError :: ChatMonad m => ChatErrorType -> m a
 throwChatError = throwError . ChatError

-deleteMemberConnection :: ChatMonad m => GroupMember -> m ()
-deleteMemberConnection m@GroupMember {activeConn} = do
-  -- User {userId} <- asks currentUser
-  withAgent (forM_ (memberConnId m) . deleteConnection) `catchError` const (pure ())
+deleteMemberConnection :: ChatMonad m => User -> GroupMember -> m ()
+deleteMemberConnection user GroupMember {activeConn} = do
+  forM_ activeConn $ \conn -> do
+    deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
+    withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
  -- withStore $ \db -> deleteGroupMemberConnection db userId m
-  forM_ activeConn $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted

 sendDirectContactMessage :: ChatMonad m => Contact -> ChatMsgEvent -> m SndMessage
 sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}} chatMsgEvent = do
@@ -2647,6 +2644,15 @@ allowAgentConnectionAsync user conn@Connection {connId} confId msg = do
  withAgent $ \a -> allowConnectionAsync a (aCorrId cmdId) (aConnId conn) confId $ directMessage msg
  withStore' $ \db -> updateConnectionStatus db conn ConnAccepted

+deleteAgentConnectionAsync :: ChatMonad m => User -> Connection -> m ()
+deleteAgentConnectionAsync user Connection {agentConnId, connId} =
+  deleteAgentConnectionAsync' user connId agentConnId
+
+deleteAgentConnectionAsync' :: ChatMonad m => User -> Int64 -> AgentConnId -> m ()
+deleteAgentConnectionAsync' user connId (AgentConnId acId) = do
+  cmdId <- withStore' $ \db -> createCommand db user (Just connId) CFDeleteConn
+  withAgent $ \a -> deleteConnectionAsync a (aCorrId cmdId) acId
+
 getCreateActiveUser :: SQLiteStore -> IO User
 getCreateActiveUser st = do
  user <-
--- a/src/Simplex/Chat/Types.hs
+++ b/src/Simplex/Chat/Types.hs
@@ -957,6 +957,7 @@ data CommandFunction
  | CFJoinConn
  | CFAllowConn
  | CFAckMessage
+  | CFDeleteConn
  deriving (Eq, Show, Generic)

 instance FromField CommandFunction where fromField = fromTextField_ textDecode
@@ -969,12 +970,14 @@ instance TextEncoding CommandFunction where
    "join_conn" -> Just CFJoinConn
    "allow_conn" -> Just CFAllowConn
    "ack_message" -> Just CFAckMessage
+    "delete_conn" -> Just CFDeleteConn
    _ -> Nothing
  textEncode = \case
    CFCreateConn -> "create_conn"
    CFJoinConn -> "join_conn"
    CFAllowConn -> "allow_conn"
    CFAckMessage -> "ack_message"
+    CFDeleteConn -> "delete_conn"

 commandExpectedResponse :: CommandFunction -> ACommandTag 'Agent
 commandExpectedResponse = \case
@@ -982,6 +985,7 @@ commandExpectedResponse = \case
  CFJoinConn -> OK_
  CFAllowConn -> OK_
  CFAckMessage -> OK_
+  CFDeleteConn -> OK_

 data CommandData = CommandData
  { cmdId :: CommandId,
--- a/stack.yaml
+++ b/stack.yaml
@@ -49,7 +49,7 @@ extra-deps:
  # - simplexmq-1.0.0@sha256:34b2004728ae396e3ae449cd090ba7410781e2b3cefc59259915f4ca5daa9ea8,8561
  # - ../simplexmq
  - github: simplex-chat/simplexmq
-    commit: 413aad5139acee28033404aed2e5516fc71c337c
+    commit: a2eea4f18f61a954daf1aa0559c0acf0ef0b1bd2
  # - ../direct-sqlcipher
  - github: simplex-chat/direct-sqlcipher
    commit: 34309410eb2069b029b8fc1872deb1e0db123294
--- a/tests/ChatTests.hs
+++ b/tests/ChatTests.hs
@@ -2440,39 +2440,70 @@ testAsyncAcceptingOffline = withTmpFiles $ do

 testFullAsync :: IO ()
 testFullAsync = withTmpFiles $ do
+  putStrLn "testFullAsync"
  inv <- withNewTestChat "alice" aliceProfile $ \alice -> do
+    putStrLn "1"
    alice ##> "/c"
+    putStrLn "2"
    getInvitation alice
+  putStrLn "3"
  withNewTestChat "bob" bobProfile $ \bob -> do
+    putStrLn "4"
    bob `send` ("/c " <> inv)
+    putStrLn "5"
    bob <### ["/c " <> inv, "confirmation sent!"]
+  putStrLn "6"
  withTestChat "alice" $ \_ -> pure () -- connecting... notification in UI
+  putStrLn "7"
  withTestChat "bob" $ \_ -> pure () -- connecting... notification in UI
+  putStrLn "8"
  withTestChat "alice" $ \alice -> do
+    putStrLn "9"
    alice <## "1 contacts connected (use /cs for the list)"
+    putStrLn "10"
    alice <## "bob (Bob): contact is connected"
+  putStrLn "11"
  withTestChat "bob" $ \bob -> do
+    putStrLn "12"
    bob <## "1 contacts connected (use /cs for the list)"
+    putStrLn "13"
    bob <## "alice (Alice): contact is connected"

 testFullAsyncV1 :: IO ()
 testFullAsyncV1 = withTmpFiles $ do
+  putStrLn "testFullAsyncV1"
  inv <- withNewAlice $ \alice -> do
+    putStrLn "1"
    alice ##> "/c"
+    putStrLn "2"
    getInvitation alice
+  putStrLn "3"
  withNewBob $ \bob -> do
+    putStrLn "4"
    bob ##> ("/c " <> inv)
+    putStrLn "5"
    bob <## "confirmation sent!"
+  putStrLn "6"
  withAlice $ \_ -> pure ()
+  putStrLn "7"
  withBob $ \_ -> pure ()
-  withAlice $ \alice ->
-    alice <## "1 contacts connected (use /cs for the list)"
-  withBob $ \_ -> pure ()
+  putStrLn "8"
  withAlice $ \alice -> do
+    putStrLn "9"
    alice <## "1 contacts connected (use /cs for the list)"
+  putStrLn "10"
+  withBob $ \_ -> pure ()
+  putStrLn "11"
+  withAlice $ \alice -> do
+    putStrLn "12"
+    alice <## "1 contacts connected (use /cs for the list)"
+    putStrLn "13"
    alice <## "bob (Bob): contact is connected"
+  putStrLn "14"
  withBob $ \bob -> do
+    putStrLn "15"
    bob <## "1 contacts connected (use /cs for the list)"
+    putStrLn "16"
    bob <## "alice (Alice): contact is connected"
  where
    withNewAlice = withNewTestChatV1 "alice" aliceProfile
@@ -2482,22 +2513,38 @@ testFullAsyncV1 = withTmpFiles $ do

 testFullAsyncV1toV2 :: IO ()
 testFullAsyncV1toV2 = withTmpFiles $ do
+  putStrLn "testFullAsyncV1toV2"
  inv <- withNewAlice $ \alice -> do
+    putStrLn "1"
    alice ##> "/c"
+    putStrLn "2"
    getInvitation alice
+  putStrLn "3"
  withNewBob $ \bob -> do
+    putStrLn "4"
    bob ##> ("/c " <> inv)
+    putStrLn "5"
    bob <## "confirmation sent!"
  withAlice $ \_ -> pure ()
+  putStrLn "6"
  withBob $ \_ -> pure ()
-  withAlice $ \alice ->
-    alice <## "1 contacts connected (use /cs for the list)"
-  withBob $ \_ -> pure ()
+  putStrLn "7"
  withAlice $ \alice -> do
+    putStrLn "8"
    alice <## "1 contacts connected (use /cs for the list)"
+  putStrLn "9"
+  withBob $ \_ -> pure ()
+  putStrLn "10"
+  withAlice $ \alice -> do
+    putStrLn "11"
+    alice <## "1 contacts connected (use /cs for the list)"
+    putStrLn "12"
    alice <## "bob (Bob): contact is connected"
+  putStrLn "13"
  withBob $ \bob -> do
+    putStrLn "14"
    bob <## "1 contacts connected (use /cs for the list)"
+    putStrLn "15"
    bob <## "alice (Alice): contact is connected"
  where
    withNewAlice = withNewTestChat "alice" aliceProfile
@@ -2507,22 +2554,39 @@ testFullAsyncV1toV2 = withTmpFiles $ do

 testFullAsyncV2toV1 :: IO ()
 testFullAsyncV2toV1 = withTmpFiles $ do
+  putStrLn "testFullAsyncV2toV1"
  inv <- withNewAlice $ \alice -> do
+    putStrLn "1"
    alice ##> "/c"
+    putStrLn "2"
    getInvitation alice
+  putStrLn "3"
  withNewBob $ \bob -> do
+    putStrLn "4"
    bob ##> ("/c " <> inv)
+    putStrLn "5"
    bob <## "confirmation sent!"
+  putStrLn "6"
  withAlice $ \_ -> pure ()
+  putStrLn "7"
  withBob $ \_ -> pure ()
-  withAlice $ \alice ->
-    alice <## "1 contacts connected (use /cs for the list)"
-  withBob $ \_ -> pure ()
+  putStrLn "8"
  withAlice $ \alice -> do
+    putStrLn "9"
    alice <## "1 contacts connected (use /cs for the list)"
+  putStrLn "10"
+  withBob $ \_ -> pure ()
+  putStrLn "11"
+  withAlice $ \alice -> do
+    putStrLn "12"
+    alice <## "1 contacts connected (use /cs for the list)"
+    putStrLn "13"
    alice <## "bob (Bob): contact is connected"
+  putStrLn "14"
  withBob $ \bob -> do
+    putStrLn "15"
    bob <## "1 contacts connected (use /cs for the list)"
+    putStrLn "16"
    bob <## "alice (Alice): contact is connected"
  where
    withNewAlice = withNewTestChatV1 "alice" aliceProfile
@@ -2885,7 +2949,7 @@ testSetChatItemTTL =
      bob <# "alice> 1"
      bob #> "@alice 2"
      alice <# "bob> 2"
-      threadDelay 1000000
+      threadDelay 2000000
      alice #> "@bob 3"
      bob <# "alice> 3"
      bob #> "@alice 4"