core: auto accept via address and incognito mode specified (#1233)

* core: Auto accept via address and incognito mode specified * Fix test * Refactoring * No forcing * Apply suggestions from code review * refactor * refactor AutoAccept * Test * Test * allow different test output order * rename * rename Co-authored-by: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
2026-03-31 22:46:13 +00:00 · 2022-10-21 19:14:12 +03:00
parent 5bcb725ea5
commit 1470b8d128
10 changed files with 108 additions and 51 deletions
--- a/simplex-chat.cabal
+++ b/simplex-chat.cabal
@@ -57,7 +57,7 @@ library
      Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
      Simplex.Chat.Migrations.M20221012_inline_files
      Simplex.Chat.Migrations.M20221019_unread_chat
-      Simplex.Chat.Migrations.M20221021_connections_via_group_link
+      Simplex.Chat.Migrations.M20221021_auto_accept__group_links
      Simplex.Chat.Mobile
      Simplex.Chat.Options
      Simplex.Chat.ProfileGenerator
--- a/src/Simplex/Chat.hs
+++ b/src/Simplex/Chat.hs
@@ -55,7 +55,7 @@ import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
 import Simplex.Chat.Store
 import Simplex.Chat.Types
-import Simplex.Chat.Util (safeDecodeUtf8, uncurry3)
+import Simplex.Chat.Util (safeDecodeUtf8)
 import Simplex.Messaging.Agent as Agent
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), AgentDatabase (..), InitialAgentServers (..), createAgentStore, defaultAgentConfig)
 import Simplex.Messaging.Agent.Protocol
@@ -773,9 +773,9 @@ processChatCommand = \case
      withStore' (`deleteUserAddress` user)
      pure CRUserContactLinkDeleted
  ShowMyAddress -> withUser $ \User {userId} ->
-    uncurry3 CRUserContactLink <$> withStore (`getUserAddress` userId)
-  AddressAutoAccept onOff msgContent -> withUser $ \User {userId} -> do
-    uncurry3 CRUserContactLinkUpdated <$> withStore (\db -> updateUserAddressAutoAccept db userId onOff msgContent)
+    CRUserContactLink <$> withStore (`getUserAddress` userId)
+  AddressAutoAccept autoAccept_ -> withUser $ \User {userId} -> do
+    CRUserContactLinkUpdated <$> withStore (\db -> updateUserAddressAutoAccept db userId autoAccept_)
  AcceptContact cName -> withUser $ \User {userId} -> do
    connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName
    processChatCommand $ APIAcceptContact connReqId
@@ -1686,7 +1686,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
              showToast (c <> "> ") "connected"
              forM_ viaUserContactLink $ \userContactLinkId ->
                withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
-                  Just (_, True, mc_, groupId_) -> do
+                  Just (UserContactLink {autoAccept = Just AutoAccept {autoReply = mc_}}, groupId_) -> do
                    forM_ mc_ $ \mc -> do
                      (msg, _) <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
                      ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing
@@ -2000,14 +2000,12 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
            CORContact contact -> toView $ CRContactRequestAlreadyAccepted contact
            CORRequest cReq@UserContactRequest {localDisplayName} -> do
              withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
-                Just (_, autoAccept, _, groupId_) ->
-                  if autoAccept
-                    then case groupId_ of
+                Just (UserContactLink {autoAccept}, groupId_) ->
+                  case autoAccept of
+                    Just AutoAccept {acceptIncognito} -> case groupId_ of
                      Nothing -> do
                        -- [incognito] generate profile to send, create connection with incognito profile
-                        -- TODO allow to configure incognito setting on auto accept instead of checking incognito mode
-                        incognito <- readTVarIO =<< asks incognitoMode
-                        incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
+                        incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
                        ct <- acceptContactRequestAsync user cReq incognitoProfile
                        toView $ CRAcceptingContactRequest ct
                      Just groupId -> do
@@ -2015,7 +2013,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
                        let profileMode = if memberIncognito membership then Just $ ExistingIncognito memberProfile else Nothing
                        ct <- acceptContactRequestAsync user cReq profileMode
                        toView $ CRAcceptingGroupJoinRequest gInfo ct
-                    else do
+                    _ -> do
                      toView $ CRReceivedContactRequest cReq
                      showToast (localDisplayName <> "> ") "wants to connect to you"
                _ -> pure ()
@@ -3180,7 +3178,7 @@ chatCommandP =
      ("/address" <|> "/ad") $> CreateMyAddress,
      ("/delete_address" <|> "/da") $> DeleteMyAddress,
      ("/show_address" <|> "/sa") $> ShowMyAddress,
-      "/auto_accept " *> (AddressAutoAccept <$> onOffP <*> optional (A.space *> msgContentP)),
+      "/auto_accept " *> (AddressAutoAccept <$> autoAcceptP),
      ("/accept @" <|> "/accept " <|> "/ac @" <|> "/ac ") *> (AcceptContact <$> displayName),
      ("/reject @" <|> "/reject " <|> "/rc @" <|> "/rc ") *> (RejectContact <$> displayName),
      ("/markdown" <|> "/m") $> ChatHelp HSMarkdown,
@@ -3253,6 +3251,11 @@ chatCommandP =
      pure $ fullNetworkConfig socksProxy tcpTimeout
    dbKeyP = nonEmptyKey <$?> strP
    nonEmptyKey k@(DBEncryptionKey s) = if null s then Left "empty key" else Right k
+    autoAcceptP =
+      ifM
+        onOffP
+        (Just <$> (AutoAccept <$> (" incognito=" *> onOffP <|> pure False) <*> optional (A.space *> msgContentP)))
+        (pure Nothing)

 adminContactReq :: ConnReqContact
 adminContactReq =
--- a/src/Simplex/Chat/Bot.hs
+++ b/src/Simplex/Chat/Bot.hs
@@ -38,7 +38,7 @@ chatBotRepl welcome answer _user cc = do
 initializeBotAddress :: ChatController -> IO ()
 initializeBotAddress cc = do
  sendChatCmd cc "/show_address" >>= \case
-    CRUserContactLink uri _ _ -> showBotAddress uri
+    CRUserContactLink UserContactLink {connReqContact} -> showBotAddress connReqContact
    CRChatCmdError (ChatErrorStore SEUserContactLinkNotFound) -> do
      putStrLn "No bot address, creating..."
      sendChatCmd cc "/address" >>= \case
--- a/src/Simplex/Chat/Controller.hs
+++ b/src/Simplex/Chat/Controller.hs
@@ -36,7 +36,7 @@ import Simplex.Chat.Call
 import Simplex.Chat.Markdown (MarkdownList)
 import Simplex.Chat.Messages
 import Simplex.Chat.Protocol
-import Simplex.Chat.Store (StoreError)
+import Simplex.Chat.Store (AutoAccept, StoreError, UserContactLink)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent (AgentClient)
 import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, InitialAgentServers, NetworkConfig)
@@ -205,7 +205,7 @@ data ChatCommand
  | CreateMyAddress
  | DeleteMyAddress
  | ShowMyAddress
-  | AddressAutoAccept Bool (Maybe MsgContent)
+  | AddressAutoAccept (Maybe AutoAccept)
  | AcceptContact ContactName
  | RejectContact ContactName
  | SendMessage ChatName ByteString
@@ -272,8 +272,8 @@ data ChatResponse
  | CRGroupCreated {groupInfo :: GroupInfo}
  | CRGroupMembers {group :: Group}
  | CRContactsList {contacts :: [Contact]}
-  | CRUserContactLink {connReqContact :: ConnReqContact, autoAccept :: Bool, autoReply :: Maybe MsgContent}
-  | CRUserContactLinkUpdated {connReqContact :: ConnReqContact, autoAccept :: Bool, autoReply :: Maybe MsgContent}
+  | CRUserContactLink UserContactLink
+  | CRUserContactLinkUpdated UserContactLink
  | CRContactRequestRejected {contactRequest :: UserContactRequest}
  | CRUserAcceptedGroupSent {groupInfo :: GroupInfo}
  | CRUserDeletedMember {groupInfo :: GroupInfo, member :: GroupMember}
--- a/src/Simplex/Chat/Migrations/M20221021_connections_via_group_link.hs
+++ b/src/Simplex/Chat/Migrations/M20221021_connections_via_group_link.hs
@@ -1,17 +1,20 @@
 {-# LANGUAGE QuasiQuotes #-}

-module Simplex.Chat.Migrations.M20221021_connections_via_group_link where
+module Simplex.Chat.Migrations.M20221021_auto_accept__group_links where

 import Database.SQLite.Simple (Query)
 import Database.SQLite.Simple.QQ (sql)

-m20221021_connections_via_group_link :: Query
-m20221021_connections_via_group_link =
+m20221021_auto_accept__group_links :: Query
+m20221021_auto_accept__group_links =
  [sql|
 PRAGMA ignore_check_constraints=ON;

 ALTER TABLE connections ADD COLUMN via_group_link INTEGER DEFAULT 0 CHECK (via_group_link NOT NULL); -- flag, 1 for connections via group link
 UPDATE connections SET via_group_link = 0;

+ALTER TABLE user_contact_links ADD column auto_accept_incognito INTEGER DEFAULT 0 CHECK (auto_accept_incognito NOT NULL);
+UPDATE user_contact_links SET auto_accept_incognito = 0;
+
 PRAGMA ignore_check_constraints=OFF;
 |]
--- a/src/Simplex/Chat/Migrations/chat_schema.sql
+++ b/src/Simplex/Chat/Migrations/chat_schema.sql
@@ -268,6 +268,7 @@ CREATE TABLE user_contact_links(
  auto_accept INTEGER DEFAULT 0,
  auto_reply_msg_content TEXT DEFAULT NULL,
  group_id INTEGER REFERENCES groups ON DELETE CASCADE,
+  auto_accept_incognito INTEGER DEFAULT 0 CHECK(auto_accept_incognito NOT NULL),
  UNIQUE(user_id, local_display_name)
 );
 CREATE TABLE contact_requests(
--- a/src/Simplex/Chat/Store.hs
+++ b/src/Simplex/Chat/Store.hs
@@ -20,6 +20,8 @@
 module Simplex.Chat.Store
  ( SQLiteStore,
    StoreError (..),
+    UserContactLink (..),
+    AutoAccept (..),
    createChatStore,
    chatStoreFile,
    agentStoreFile,
@@ -283,7 +285,7 @@ import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
 import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
 import Simplex.Chat.Migrations.M20221012_inline_files
 import Simplex.Chat.Migrations.M20221019_unread_chat
-import Simplex.Chat.Migrations.M20221021_connections_via_group_link
+import Simplex.Chat.Migrations.M20221021_auto_accept__group_links
 import Simplex.Chat.Protocol
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
@@ -327,7 +329,7 @@ schemaMigrations =
    ("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id),
    ("20221012_inline_files", m20221012_inline_files),
    ("20221019_unread_chat", m20221019_unread_chat),
-    ("20221021_connections_via_group_link", m20221021_connections_via_group_link)
+    ("20221021_auto_accept__group_links", m20221021_auto_accept__group_links)
  ]

 -- | The list of migrations in ascending order by date
@@ -785,47 +787,69 @@ deleteUserAddress db User {userId} = do
    [":user_id" := userId]
  DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId)

-getUserAddress :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
+data UserContactLink = UserContactLink
+  { connReqContact :: ConnReqContact,
+    autoAccept :: Maybe AutoAccept
+  }
+  deriving (Show, Generic)
+
+instance ToJSON UserContactLink where toEncoding = J.genericToEncoding J.defaultOptions
+
+data AutoAccept = AutoAccept
+  { acceptIncognito :: Bool,
+    autoReply :: Maybe MsgContent
+  }
+  deriving (Show, Generic)
+
+instance ToJSON AutoAccept where toEncoding = J.genericToEncoding J.defaultOptions
+
+toUserContactLink :: (ConnReqContact, Bool, Bool, Maybe MsgContent) -> UserContactLink
+toUserContactLink (connReq, autoAccept, acceptIncognito, autoReply) =
+  UserContactLink connReq $
+    if autoAccept then Just AutoAccept {acceptIncognito, autoReply} else Nothing
+
+getUserAddress :: DB.Connection -> UserId -> ExceptT StoreError IO UserContactLink
 getUserAddress db userId =
-  ExceptT . firstRow id SEUserContactLinkNotFound $
+  ExceptT . firstRow toUserContactLink SEUserContactLinkNotFound $
    DB.query
      db
      [sql|
-        SELECT conn_req_contact, auto_accept, auto_reply_msg_content
+        SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content
        FROM user_contact_links
        WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
      |]
      (Only userId)

-getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (ConnReqContact, Bool, Maybe MsgContent, Maybe GroupId))
+getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (UserContactLink, Maybe GroupId))
 getUserContactLinkById db userId userContactLinkId =
-  maybeFirstRow id $
+  maybeFirstRow (\(ucl :. Only groupId_) -> (toUserContactLink ucl, groupId_)) $
    DB.query
      db
      [sql|
-        SELECT conn_req_contact, auto_accept, auto_reply_msg_content, group_id
+        SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content, group_id
        FROM user_contact_links
        WHERE user_id = ?
          AND user_contact_link_id = ?
      |]
      (userId, userContactLinkId)

-updateUserAddressAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
-updateUserAddressAutoAccept db userId autoAccept msgContent = do
-  (cReqUri, _, _) <- getUserAddress db userId
-  liftIO updateUserAddressAutoAccept_
-  pure (cReqUri, autoAccept, msgContent)
+updateUserAddressAutoAccept :: DB.Connection -> UserId -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
+updateUserAddressAutoAccept db userId autoAccept = do
+  link <- getUserAddress db userId
+  liftIO updateUserAddressAutoAccept_ $> link {autoAccept}
  where
-    updateUserAddressAutoAccept_ :: IO ()
    updateUserAddressAutoAccept_ =
      DB.execute
        db
        [sql|
          UPDATE user_contact_links
-          SET auto_accept = ?, auto_reply_msg_content = ?
+          SET auto_accept = ?, auto_accept_incognito = ?, auto_reply_msg_content = ?
          WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
        |]
-        (autoAccept, msgContent, userId)
+        (ucl :. Only userId)
+    ucl = case autoAccept of
+      Just AutoAccept {acceptIncognito, autoReply} -> (True, acceptIncognito, autoReply)
+      _ -> (False, False, Nothing)

 createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
 createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq =
@@ -2251,7 +2275,7 @@ createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO Sn
 createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
  currentTs <- getCurrentTime
  let fileStatus = FSConnected
-      fileInline' = Just $ fromMaybe (IFMOffer) fileInline
+      fileInline' = Just $ fromMaybe IFMOffer fileInline
  DB.execute
    db
    "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
@@ -2262,7 +2286,7 @@ createSndGroupInlineFT :: DB.Connection -> GroupMember -> Connection -> FileTran
 createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Connection {connId, agentConnId} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
  currentTs <- getCurrentTime
  let fileStatus = FSConnected
-      fileInline' = Just $ fromMaybe (IFMOffer) fileInline
+      fileInline' = Just $ fromMaybe IFMOffer fileInline
  DB.execute
    db
    "INSERT INTO snd_files (file_id, file_status, file_inline, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
--- a/src/Simplex/Chat/Util.hs
+++ b/src/Simplex/Chat/Util.hs
@@ -8,6 +8,3 @@ safeDecodeUtf8 :: ByteString -> Text
 safeDecodeUtf8 = decodeUtf8With onError
  where
    onError _ _ = Just '?'
-
-uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
-uncurry3 f ~(a, b, c) = f a b c
--- a/src/Simplex/Chat/View.hs
+++ b/src/Simplex/Chat/View.hs
@@ -34,7 +34,7 @@ import Simplex.Chat.Help
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Protocol
-import Simplex.Chat.Store (StoreError (..))
+import Simplex.Chat.Store (AutoAccept (..), StoreError (..), UserContactLink (..))
 import Simplex.Chat.Styled
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Env.SQLite (NetworkConfig (..))
@@ -87,8 +87,8 @@ responseToView testView = \case
    HSSettings -> settingsInfo
  CRWelcome user -> chatWelcome user
  CRContactsList cs -> viewContactsList cs
-  CRUserContactLink cReqUri autoAccept autoReply -> connReqContact_ "Your chat address:" cReqUri <> autoAcceptStatus_ autoAccept autoReply
-  CRUserContactLinkUpdated _ autoAccept autoReply -> autoAcceptStatus_ autoAccept autoReply
+  CRUserContactLink UserContactLink {connReqContact, autoAccept} -> connReqContact_ "Your chat address:" connReqContact <> autoAcceptStatus_ autoAccept
+  CRUserContactLinkUpdated UserContactLink {autoAccept} -> autoAcceptStatus_ autoAccept
  CRContactRequestRejected UserContactRequest {localDisplayName = c} -> [ttyContact c <> ": contact request rejected"]
  CRGroupCreated g -> viewGroupCreated g
  CRGroupMembers g -> viewGroupMembers g
@@ -428,10 +428,12 @@ connReqContact_ intro cReq =
    "to delete it: " <> highlight' "/da" <> " (accepted contacts will remain connected)"
  ]

-autoAcceptStatus_ :: Bool -> Maybe MsgContent -> [StyledString]
-autoAcceptStatus_ autoAccept autoReply =
-  ("auto_accept " <> if autoAccept then "on" else "off") :
-  maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
+autoAcceptStatus_ :: Maybe AutoAccept -> [StyledString]
+autoAcceptStatus_ = \case
+  Just AutoAccept {acceptIncognito, autoReply} ->
+    ("auto_accept on" <> if acceptIncognito then ", incognito" else "") :
+    maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
+  _ -> ["auto_accept off"]

 groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> [StyledString]
 groupLink_ intro g cReq =
--- a/tests/ChatTests.hs
+++ b/tests/ChatTests.hs
@@ -100,6 +100,7 @@ chatTests = do
    it "reject contact and delete contact link" testRejectContactAndDeleteUserContact
    it "delete connection requests when contact link deleted" testDeleteConnectionRequests
    it "auto-reply message" testAutoReplyMessage
+    it "auto-reply message in incognito" testAutoReplyMessageInIncognito
  describe "incognito mode" $ do
    it "connect incognito via invitation link" testConnectIncognitoInvitationLink
    it "connect incognito via contact address" testConnectIncognitoContactAddress
@@ -2314,7 +2315,7 @@ testAutoReplyMessage = testChat2 aliceProfile bobProfile $
  \alice bob -> do
    alice ##> "/ad"
    cLink <- getContactLink alice True
-    alice ##> "/auto_accept on text hello!"
+    alice ##> "/auto_accept on incognito=off text hello!"
    alice <## "auto_accept on"
    alice <## "auto reply:"
    alice <## "hello!"
@@ -2331,6 +2332,32 @@ testAutoReplyMessage = testChat2 aliceProfile bobProfile $
          alice <# "@bob hello!"
      ]

+testAutoReplyMessageInIncognito :: IO ()
+testAutoReplyMessageInIncognito = testChat2 aliceProfile bobProfile $
+  \alice bob -> do
+    alice ##> "/ad"
+    cLink <- getContactLink alice True
+    alice ##> "/auto_accept on incognito=on text hello!"
+    alice <## "auto_accept on, incognito"
+    alice <## "auto reply:"
+    alice <## "hello!"
+
+    bob ##> ("/c " <> cLink)
+    bob <## "connection request sent!"
+    alice <## "bob (Bob): accepting contact request..."
+    aliceIncognito <- getTermLine alice
+    concurrentlyN_
+      [ do
+          bob <## (aliceIncognito <> ": contact is connected")
+          bob <# (aliceIncognito <> "> hello!"),
+        do
+          alice <## ("bob (Bob): contact is connected, your incognito profile for this contact is " <> aliceIncognito)
+          alice
+            <### [ "use /info bob to print out this incognito profile again",
+                   WithTime "i @bob hello!"
+                 ]
+      ]
+
 testConnectIncognitoInvitationLink :: IO ()
 testConnectIncognitoInvitationLink = testChat3 aliceProfile bobProfile cathProfile $
  \alice bob cath -> do