core: api to abort connection switch; update simplexmq (#2544)

2023-06-16 19:05:53 +04:00 · 2023-06-16 19:05:53 +04:00 · 6d3cb0ea2e
commit 6d3cb0ea2e
parent 46c6f5e615
8 changed files with 131 additions and 15 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: 89caf5572980b776bd750caa3c918ae4488612d8
+    tag: 2efe1496d2622a56656a6a00a2cc19005e754468

 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"."89caf5572980b776bd750caa3c918ae4488612d8" = "0glils00403s4xxl84xa22wylfsrcpjj5j3v7srqhrmikm1jds4p";
+  "https://github.com/simplex-chat/simplexmq.git"."2efe1496d2622a56656a6a00a2cc19005e754468" = "0syy10zn3ci1nbs00r0l5vhvqkwlqcgmmd5c196pch0xvrk5qbfi";
  "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38";
  "https://github.com/kazu-yamamoto/http2.git"."b5a1b7200cf5bc7044af34ba325284271f6dff25" = "0dqb50j57an64nf4qcf5vcz4xkd1vzvghvf8bk529c1k30r9nfzb";
  "https://github.com/simplex-chat/direct-sqlcipher.git"."34309410eb2069b029b8fc1872deb1e0db123294" = "0kwkmhyfsn2lixdlgl15smgr1h5gjk7fky6abzh8rng2h5ymnffd";
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@ -1110,6 +1110,17 @@ processChatCommand = \case
    case memberConnId m of
      Just connId -> withAgent (\a -> switchConnectionAsync a "" connId) >> ok user
      _ -> throwChatError CEGroupMemberNotActive
+  APIAbortSwitchContact contactId -> withUser $ \user -> do
+    ct <- withStore $ \db -> getContact db user contactId
+    connectionStats <- withAgent $ \a -> abortConnectionSwitch a $ contactConnId ct
+    pure $ CRContactSwitchAborted user ct connectionStats
+  APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
+    (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
+    case memberConnId m of
+      Just connId -> do
+        connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
+        pure $ CRGroupMemberSwitchAborted user g m connectionStats
+      _ -> throwChatError CEGroupMemberNotActive
  APIGetContactCode contactId -> withUser $ \user -> do
    ct@Contact {activeConn = conn@Connection {connId}} <- withStore $ \db -> getContact db user contactId
    code <- getConnectionCode (contactConnId ct)
@ -1164,6 +1175,8 @@ processChatCommand = \case
  GroupMemberInfo gName mName -> withMemberName gName mName APIGroupMemberInfo
  SwitchContact cName -> withContactName cName APISwitchContact
  SwitchGroupMember gName mName -> withMemberName gName mName APISwitchGroupMember
+  AbortSwitchContact cName -> withContactName cName APIAbortSwitchContact
+  AbortSwitchGroupMember gName mName -> withMemberName gName mName APIAbortSwitchGroupMember
  GetContactCode cName -> withContactName cName APIGetContactCode
  GetGroupMemberCode gName mName -> withMemberName gName mName APIGetGroupMemberCode
  VerifyContact cName code -> withContactName cName (`APIVerifyContact` code)
@ -2810,7 +2823,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
            _ -> pure ()
        SWITCH qd phase cStats -> do
          toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats)
-          when (phase /= SPConfirmed) $ case qd of
+          when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
            QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing
            QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
        OK ->
@ -2989,7 +3002,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
        checkSndInlineFTComplete conn msgId
      SWITCH qd phase cStats -> do
        toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
-        when (phase /= SPConfirmed) $ case qd of
+        when (phase `elem` [SPStarted, SPCompleted]) $ case qd of
          QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
          QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
      OK ->
@ -4858,8 +4871,12 @@ chatCommandP =
      ("/info " <|> "/i ") *> char_ '@' *> (ContactInfo <$> displayName),
      "/_switch #" *> (APISwitchGroupMember <$> A.decimal <* A.space <*> A.decimal),
      "/_switch @" *> (APISwitchContact <$> A.decimal),
+      "/_abort switch #" *> (APIAbortSwitchGroupMember <$> A.decimal <* A.space <*> A.decimal),
+      "/_abort switch @" *> (APIAbortSwitchContact <$> A.decimal),
      "/switch #" *> (SwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
      "/switch " *> char_ '@' *> (SwitchContact <$> displayName),
+      "/abort switch #" *> (AbortSwitchGroupMember <$> displayName <* A.space <* char_ '@' <*> displayName),
+      "/abort switch " *> char_ '@' *> (AbortSwitchContact <$> displayName),
      "/_get code @" *> (APIGetContactCode <$> A.decimal),
      "/_get code #" *> (APIGetGroupMemberCode <$> A.decimal <* A.space <*> A.decimal),
      "/_verify code @" *> (APIVerifyContact <$> A.decimal <*> optional (A.space *> textP)),
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@ -284,6 +284,8 @@ data ChatCommand
  | APIGroupMemberInfo GroupId GroupMemberId
  | APISwitchContact ContactId
  | APISwitchGroupMember GroupId GroupMemberId
+  | APIAbortSwitchContact ContactId
+  | APIAbortSwitchGroupMember GroupId GroupMemberId
  | APIGetContactCode ContactId
  | APIGetGroupMemberCode GroupId GroupMemberId
  | APIVerifyContact ContactId (Maybe Text)
@ -295,6 +297,8 @@ data ChatCommand
  | GroupMemberInfo GroupName ContactName
  | SwitchContact ContactName
  | SwitchGroupMember GroupName ContactName
+  | AbortSwitchContact ContactName
+  | AbortSwitchGroupMember GroupName ContactName
  | GetContactCode ContactName
  | GetGroupMemberCode GroupName ContactName
  | VerifyContact ContactName (Maybe Text)
@ -403,6 +407,8 @@ data ChatResponse
  | CRNetworkConfig {networkConfig :: NetworkConfig}
  | CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile}
  | CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
+  | CRContactSwitchAborted {user :: User, contact :: Contact, connectionStats :: ConnectionStats}
+  | CRGroupMemberSwitchAborted {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats :: ConnectionStats}
  | CRContactSwitch {user :: User, contact :: Contact, switchProgress :: SwitchProgress}
  | CRGroupMemberSwitch {user :: User, groupInfo :: GroupInfo, member :: GroupMember, switchProgress :: SwitchProgress}
  | CRContactCode {user :: User, contact :: Contact, connectionCode :: Text}
--- a/src/Simplex/Chat/Messages/ChatItemContent.hs
+++ b/src/Simplex/Chat/Messages/ChatItemContent.hs
@ -383,14 +383,18 @@ sndGroupEventToText = \case
 rcvConnEventToText :: RcvConnEvent -> Text
 rcvConnEventToText = \case
  RCESwitchQueue phase -> case phase of
+    SPStarted -> "started changing address for you..."
+    SPConfirmed -> "confirmed changing address for you..."
+    SPSecured -> "secured new address for you..."
    SPCompleted -> "changed address for you"
-    _ -> decodeLatin1 (strEncode phase) <> " changing address for you..."

 sndConnEventToText :: SndConnEvent -> Text
 sndConnEventToText = \case
  SCESwitchQueue phase m -> case phase of
+    SPStarted -> "started changing address" <> forMember m <> "..."
+    SPConfirmed -> "confirmed changing address" <> forMember m <> "..."
+    SPSecured -> "secured new address" <> forMember m <> "..."
    SPCompleted -> "you changed address" <> forMember m
-    _ -> decodeLatin1 (strEncode phase) <> " changing address" <> forMember m <> "..."
  where
    forMember member_ =
      maybe "" (\GroupMemberRef {profile = Profile {displayName}} -> " for " <> displayName) member_
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@ -47,6 +47,7 @@ import qualified Simplex.FileTransfer.Protocol as XFTP
 import Simplex.Messaging.Agent.Client (ProtocolTestFailure (..), ProtocolTestStep (..))
 import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
 import Simplex.Messaging.Agent.Protocol
+import Simplex.Messaging.Agent.Store (canAbortRcvSwitch)
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Encoding
 import Simplex.Messaging.Encoding.String
@ -80,6 +81,8 @@ responseToView user_ ChatConfig {logLevel, showReactions, testView} liveItems ts
  CRNetworkConfig cfg -> viewNetworkConfig cfg
  CRContactInfo u ct cStats customUserProfile -> ttyUser u $ viewContactInfo ct cStats customUserProfile
  CRGroupMemberInfo u g m cStats -> ttyUser u $ viewGroupMemberInfo g m cStats
+  CRContactSwitchAborted {} -> ["switch aborted"]
+  CRGroupMemberSwitchAborted {} -> ["switch aborted"]
  CRContactSwitch u ct progress -> ttyUser u $ viewContactSwitch ct progress
  CRGroupMemberSwitch u g m progress -> ttyUser u $ viewGroupMemberSwitch g m progress
  CRConnectionVerified u verified code -> ttyUser u [plain $ if verified then "connection verified" else "connection not verified, current code is " <> code]
@ -918,24 +921,46 @@ viewConnectionVerified (Just _) = "connection verified" -- TODO show verificatio
 viewConnectionVerified _ = "connection not verified, use " <> highlight' "/code" <> " command to see security code"

 viewConnectionStats :: ConnectionStats -> [StyledString]
-viewConnectionStats ConnectionStats {rcvServers, sndServers} =
-  ["receiving messages via: " <> viewServerHosts rcvServers | not $ null rcvServers]
-    <> ["sending messages via: " <> viewServerHosts sndServers | not $ null sndServers]
+viewConnectionStats ConnectionStats {rcvQueuesInfo, sndQueuesInfo} =
+  ["receiving messages via: " <> viewRcvQueuesInfo rcvQueuesInfo | not $ null rcvQueuesInfo]
+    <> ["sending messages via: " <> viewSndQueuesInfo sndQueuesInfo | not $ null sndQueuesInfo]

 viewServers :: ProtocolTypeI p => (a -> ProtoServerWithAuth p) -> NonEmpty a -> [StyledString]
 viewServers f = map (plain . B.unpack . strEncode . f) . L.toList

-viewServerHosts :: [SMPServer] -> StyledString
-viewServerHosts = plain . intercalate ", " . map showSMPServer
+viewRcvQueuesInfo :: [RcvQueueInfo] -> StyledString
+viewRcvQueuesInfo = plain . intercalate ", " . map showQueueInfo
+  where
+    showQueueInfo RcvQueueInfo {rcvServer, rcvSwitchStatus, canAbortSwitch} =
+      let switchCanBeAborted = if canAbortSwitch then ", can be aborted" else ""
+       in showSMPServer rcvServer
+            <> maybe "" (\s -> " (" <> showSwitchStatus s <> switchCanBeAborted <> ")") rcvSwitchStatus
+    showSwitchStatus = \case
+      RSSwitchStarted -> "switch started"
+      RSSendingQADD -> "switch started"
+      RSSendingQUSE -> "switch confirmed"
+      RSReceivedMessage -> "switch secured"
+
+viewSndQueuesInfo :: [SndQueueInfo] -> StyledString
+viewSndQueuesInfo = plain . intercalate ", " . map showQueueInfo
+  where
+    showQueueInfo SndQueueInfo {sndServer, sndSwitchStatus} =
+      showSMPServer sndServer
+        <> maybe "" (\s -> " (" <> showSwitchStatus s <> ")") sndSwitchStatus
+    showSwitchStatus = \case
+      SSSendingQKEY -> "switch started"
+      SSSendingQTEST -> "switch secured"

 viewContactSwitch :: Contact -> SwitchProgress -> [StyledString]
 viewContactSwitch _ (SwitchProgress _ SPConfirmed _) = []
+viewContactSwitch _ (SwitchProgress _ SPSecured _) = []
 viewContactSwitch ct (SwitchProgress qd phase _) = case qd of
  QDRcv -> [ttyContact' ct <> ": you " <> viewSwitchPhase phase]
  QDSnd -> [ttyContact' ct <> " " <> viewSwitchPhase phase <> " for you"]

 viewGroupMemberSwitch :: GroupInfo -> GroupMember -> SwitchProgress -> [StyledString]
 viewGroupMemberSwitch _ _ (SwitchProgress _ SPConfirmed _) = []
+viewGroupMemberSwitch _ _ (SwitchProgress _ SPSecured _) = []
 viewGroupMemberSwitch g m (SwitchProgress qd phase _) = case qd of
  QDRcv -> [ttyGroup' g <> ": you " <> viewSwitchPhase phase <> " for " <> ttyMember m]
  QDSnd -> [ttyGroup' g <> ": " <> ttyMember m <> " " <> viewSwitchPhase phase <> " for you"]
@ -952,8 +977,11 @@ viewSecurityCode name cmd code testView
  | otherwise = [name <> " security code:", plain code, "pass this code to your contact and use " <> highlight cmd <> " to verify"]

 viewSwitchPhase :: SwitchPhase -> StyledString
-viewSwitchPhase SPCompleted = "changed address"
-viewSwitchPhase phase = plain (strEncode phase) <> " changing address"
+viewSwitchPhase = \case
+  SPStarted -> "started changing address"
+  SPConfirmed -> "confirmed changing address"
+  SPSecured -> "secured new address"
+  SPCompleted -> "changed address"

 viewUserProfileUpdated :: Profile -> Profile -> [StyledString]
 viewUserProfileUpdated Profile {displayName = n, fullName, image, contactLink, preferences} Profile {displayName = n', fullName = fullName', image = image', contactLink = contactLink', preferences = prefs'} =
@ -1478,6 +1506,7 @@ viewChatError logLevel = \case
    DBErrorOpen e -> ["error opening database after encryption: " <> sqliteError' e]
    e -> ["chat database error: " <> sShow e]
  ChatErrorAgent err entity_ -> case err of
+    CMD PROHIBITED -> [withConnEntity <> "error: command is prohibited"]
    SMP SMP.AUTH ->
      [ withConnEntity
          <> "error: connection authorization failed - this could happen if connection was deleted,\
--- 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: 89caf5572980b776bd750caa3c918ae4488612d8
+    commit: 2efe1496d2622a56656a6a00a2cc19005e754468
  - github: kazu-yamamoto/http2
    commit: b5a1b7200cf5bc7044af34ba325284271f6dff25
  # - ../direct-sqlcipher
--- a/tests/ChatTests/Direct.hs
+++ b/tests/ChatTests/Direct.hs
@ -73,9 +73,11 @@ chatDirectTests = do
    it "user profile privacy: hide profiles and notificaitons" testUserPrivacy
  describe "chat item expiration" $ do
    it "set chat item TTL" testSetChatItemTTL
-  describe "queue rotation" $ do
+  describe "connection switch" $ do
    it "switch contact to a different queue" testSwitchContact
+    it "stop switching contact to a different queue" testAbortSwitchContact
    it "switch group member to a different queue" testSwitchGroupMember
+    it "stop switching group member to a different queue" testAbortSwitchGroupMember
  describe "connection verification code" $ do
    it "verificationCode function converts ByteString to series of digits" $ \_ ->
      verificationCode (C.sha256Hash "abcd") `shouldBe` "61889 38426 63934 09576 96390 79389 84124 85253 63658 69469 70853 37788 95900 68296 20156 25"
@ -1845,6 +1847,33 @@ testSwitchContact =
      bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "started changing address for you..."), (0, "changed address for you")])
      alice <##> bob

+testAbortSwitchContact :: HasCallStack => FilePath -> IO ()
+testAbortSwitchContact tmp = do
+  withNewTestChat tmp "alice" aliceProfile $ \alice -> do
+    withNewTestChat tmp "bob" bobProfile $ \bob -> do
+      connectUsers alice bob
+    alice #$> ("/switch bob", id, "ok")
+    alice <## "bob: you started changing address"
+    -- repeat switch is prohibited
+    alice ##> "/switch bob"
+    alice <## "error: command is prohibited"
+    -- stop switch
+    alice #$> ("/abort switch bob", id, "switch aborted")
+    -- repeat switch stop is prohibited
+    alice ##> "/abort switch bob"
+    alice <## "error: command is prohibited"
+    withTestChatContactConnected tmp "bob" $ \bob -> do
+      bob <## "alice started changing address for you"
+      -- alice changes address again
+      alice #$> ("/switch bob", id, "ok")
+      alice <## "bob: you started changing address"
+      bob <## "alice started changing address for you"
+      bob <## "alice changed address for you"
+      alice <## "bob: you changed address"
+      alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "started changing address..."), (1, "started changing address..."), (1, "you changed address")])
+      bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")])
+      alice <##> bob
+
 testSwitchGroupMember :: HasCallStack => FilePath -> IO ()
 testSwitchGroupMember =
  testChat2 aliceProfile bobProfile $
@ -1862,6 +1891,37 @@ testSwitchGroupMember =
      bob #> "#team hi"
      alice <# "#team bob> hi"

+testAbortSwitchGroupMember :: HasCallStack => FilePath -> IO ()
+testAbortSwitchGroupMember tmp = do
+  withNewTestChat tmp "alice" aliceProfile $ \alice -> do
+    withNewTestChat tmp "bob" bobProfile $ \bob -> do
+      createGroup2 "team" alice bob
+    alice #$> ("/switch #team bob", id, "ok")
+    alice <## "#team: you started changing address for bob"
+    -- repeat switch is prohibited
+    alice ##> "/switch #team bob"
+    alice <## "error: command is prohibited"
+    -- stop switch
+    alice #$> ("/abort switch #team bob", id, "switch aborted")
+    -- repeat switch stop is prohibited
+    alice ##> "/abort switch #team bob"
+    alice <## "error: command is prohibited"
+    withTestChatContactConnected tmp "bob" $ \bob -> do
+      bob <## "#team: connected to server(s)"
+      bob <## "#team: alice started changing address for you"
+      -- alice changes address again
+      alice #$> ("/switch #team bob", id, "ok")
+      alice <## "#team: you started changing address for bob"
+      bob <## "#team: alice started changing address for you"
+      bob <## "#team: alice changed address for you"
+      alice <## "#team: you changed address for bob"
+      alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "started changing address for bob..."), (1, "started changing address for bob..."), (1, "you changed address for bob")])
+      bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "started changing address for you..."), (0, "started changing address for you..."), (0, "changed address for you")])
+      alice #> "#team hey"
+      bob <# "#team alice> hey"
+      bob #> "#team hi"
+      alice <# "#team bob> hi"
+
 testMarkContactVerified :: HasCallStack => FilePath -> IO ()
 testMarkContactVerified =
  testChat2 aliceProfile bobProfile $ \alice bob -> do