core: support sending direct messages to members (#5680)

2026-05-24 19:35:33 +00:00 · 2025-02-28 11:40:19 +04:00
parent 438b11eb6a
commit ce6f2acbdc
7 changed files with 88 additions and 39 deletions
@@ -70,7 +70,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId'
 sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO ()
 sendComposedMessage' cc ctId quotedItemId msgContent = do
  let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent, mentions = M.empty}
-  sendChatCmd cc (APISendMessages (ChatRef CTDirect ctId) False Nothing [cm]) >>= \case
+  sendChatCmd cc (APISendMessages (SRDirect ctId) False Nothing [cm]) >>= \case
    CRNewChatItems {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId
    r -> putStrLn $ "unexpected send message response: " <> show r

@@ -308,7 +308,7 @@ data ChatCommand
  | APIGetChat ChatRef (Maybe MsgContentTag) ChatPagination (Maybe String)
  | APIGetChatItems ChatPagination (Maybe String)
  | APIGetChatItemInfo ChatRef ChatItemId
-  | APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
+  | APISendMessages {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
  | APICreateChatTag ChatTagData
  | APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId))
  | APIDeleteChatTag ChatTagId
@@ -902,6 +902,17 @@ logResponseToFile = \case
  CRMessageError {} -> True
  _ -> False

+-- (Maybe GroupMemberId) can later be changed to GroupSndScope = GSSAll | GSSAdmins | GSSMember GroupMemberId
+data SendRef
+  = SRDirect ContactId
+  | SRGroup GroupId (Maybe GroupMemberId)
+  deriving (Eq, Show)
+
+sendToChatRef :: SendRef -> ChatRef
+sendToChatRef = \case
+  SRDirect cId -> ChatRef CTDirect cId
+  SRGroup gId _ -> ChatRef CTGroup gId
+
 data ChatPagination
  = CPLast Int
  | CPAfter ChatItemId Int
@@ -538,20 +538,17 @@ processChatCommand' vr = \case
        Just (CIFFGroup _ _ (Just gId) (Just fwdItemId)) ->
          Just <$> withFastStore (\db -> getAChatItem db vr user (ChatRef CTGroup gId) fwdItemId)
        _ -> pure Nothing
-  APISendMessages (ChatRef cType chatId) live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case cType of
-    CTDirect -> do
+  APISendMessages sendRef live itemTTL cms -> withUser $ \user -> mapM_ assertAllowedContent' cms >> case sendRef of
+    SRDirect chatId -> do
      mapM_ assertNoMentions cms
      withContactLock "sendMessage" chatId $
        sendContactContentMessages user chatId live itemTTL (L.map composedMessageReq cms)
-    CTGroup ->
+    SRGroup chatId directMemberId ->
      withGroupLock "sendMessage" chatId $ do
        (gInfo, cmrs) <- withFastStore $ \db -> do
          g <- getGroupInfo db vr user chatId
          (g,) <$> mapM (composedMessageReqMentions db user g) cms
-        sendGroupContentMessages user gInfo live itemTTL cmrs
-    CTLocal -> pure $ chatCmdError (Just user) "not supported"
-    CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
-    CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
+        sendGroupContentMessages user gInfo directMemberId live itemTTL cmrs
  APICreateChatTag (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
    _ <- createChatTag db user emoji text
    CRChatTags user <$> getUserChatTags db user
@@ -849,7 +846,7 @@ processChatCommand' vr = \case
        Just cmrs' ->
          withGroupLock "forwardChatItem, to group" toChatId $ do
            gInfo <- withFastStore $ \db -> getGroupInfo db vr user toChatId
-            sendGroupContentMessages user gInfo False itemTTL cmrs'
+            sendGroupContentMessages user gInfo Nothing False itemTTL cmrs'
        Nothing -> pure $ CRNewChatItems user []
    CTLocal -> do
      cmrs <- prepareForward user
@@ -1840,8 +1837,8 @@ processChatCommand' vr = \case
      CTDirect ->
        withFastStore' (\db -> runExceptT $ getContactIdByName db user name) >>= \case
          Right ctId -> do
-            let chatRef = ChatRef CTDirect ctId
-            processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
+            let sendRef = SRDirect ctId
+            processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
          Left _ ->
            withFastStore' (\db -> runExceptT $ getActiveMembersByName db vr user name) >>= \case
              Right [(gInfo, member)] -> do
@@ -1856,8 +1853,8 @@ processChatCommand' vr = \case
        (gId, mentions) <- withFastStore $ \db -> do
          gId <- getGroupIdByName db user name
          (gId,) <$> liftIO (getMessageMentions db user gId msg)
-        let chatRef = ChatRef CTGroup gId
-        processChatCommand $ APISendMessages chatRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
+        let sendRef = SRGroup gId Nothing
+        processChatCommand $ APISendMessages sendRef False Nothing [ComposedMessage Nothing Nothing mc mentions]
      CTLocal
        | name == "" -> do
            folderId <- withFastStore (`getUserNoteFolderId` user)
@@ -1879,12 +1876,13 @@ processChatCommand' vr = \case
            processChatCommand $ APISendMemberContactInvitation contactId (Just mc)
          cr -> pure cr
      Just ctId -> do
-        let chatRef = ChatRef CTDirect ctId
-        processChatCommand $ APISendMessages chatRef False Nothing [composedMessage Nothing mc]
+        let sendRef = SRDirect ctId
+        processChatCommand $ APISendMessages sendRef False Nothing [composedMessage Nothing mc]
  SendLiveMessage chatName msg -> withUser $ \user -> do
    (chatRef, mentions) <- getChatRefAndMentions user chatName msg
-    let mc = MCText msg
-    processChatCommand $ APISendMessages chatRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
+    withSendRef chatRef $ \sendRef -> do
+      let mc = MCText msg
+      processChatCommand $ APISendMessages sendRef True Nothing [ComposedMessage Nothing Nothing mc mentions]
  SendMessageBroadcast msg -> withUser $ \user -> do
    contacts <- withFastStore' $ \db -> getUserContacts db vr user
    withChatLock "sendMessageBroadcast" . procCmd $ do
@@ -1929,7 +1927,7 @@ processChatCommand' vr = \case
    contactId <- withFastStore $ \db -> getContactIdByName db user cName
    quotedItemId <- withFastStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg
    let mc = MCText msg
-    processChatCommand $ APISendMessages (ChatRef CTDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
+    processChatCommand $ APISendMessages (SRDirect contactId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc M.empty]
  DeleteMessage chatName deletedMsg -> withUser $ \user -> do
    chatRef <- getChatRef user chatName
    deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
@@ -2235,7 +2233,7 @@ processChatCommand' vr = \case
        qiId <- getGroupChatItemIdByText db user gId cName quotedMsg
        (gId, qiId,) <$> liftIO (getMessageMentions db user gId msg)
    let mc = MCText msg
-    processChatCommand $ APISendMessages (ChatRef CTGroup groupId) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
+    processChatCommand $ APISendMessages (SRGroup groupId Nothing) False Nothing [ComposedMessage Nothing (Just quotedItemId) mc mentions]
  ClearNoteFolder -> withUser $ \user -> do
    folderId <- withFastStore (`getUserNoteFolderId` user)
    processChatCommand $ APIClearChat (ChatRef CTLocal folderId)
@@ -2276,15 +2274,16 @@ processChatCommand' vr = \case
    chatRef <- getChatRef user chatName
    case chatRef of
      ChatRef CTLocal folderId -> processChatCommand $ APICreateChatItems folderId [composedMessage (Just f) (MCFile "")]
-      _ -> processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCFile "")]
+      _ -> withSendRef chatRef $ \sendRef -> processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCFile "")]
  SendImage chatName f@(CryptoFile fPath _) -> withUser $ \user -> do
    chatRef <- getChatRef user chatName
-    filePath <- lift $ toFSFilePath fPath
-    unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
-    fileSize <- getFileSize filePath
-    unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
-    -- TODO include file description for preview
-    processChatCommand $ APISendMessages chatRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
+    withSendRef chatRef $ \sendRef -> do
+      filePath <- lift $ toFSFilePath fPath
+      unless (any (`isSuffixOf` map toLower fPath) imageExtensions) $ throwChatError CEFileImageType {filePath}
+      fileSize <- getFileSize filePath
+      unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath}
+      -- TODO include file description for preview
+      processChatCommand $ APISendMessages sendRef False Nothing [composedMessage (Just f) (MCImage "" fixedImagePreview)]
  ForwardFile chatName fileId -> forwardFile chatName fileId SendFile
  ForwardImage chatName fileId -> forwardFile chatName fileId SendImage
  SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO"
@@ -3066,10 +3065,16 @@ processChatCommand' vr = \case
                quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
                quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
                quoteData _ = throwError SEInvalidQuote
-    sendGroupContentMessages :: User -> GroupInfo -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
-    sendGroupContentMessages user gInfo live itemTTL cmrs = do
+    sendGroupContentMessages :: User -> GroupInfo -> Maybe GroupMemberId -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
+    sendGroupContentMessages user gInfo@GroupInfo {membership} directMemberId live itemTTL cmrs = do
      assertMultiSendable live cmrs
-      ms <- withFastStore' $ \db -> getGroupMembers db vr user gInfo
+      ms <- case directMemberId of
+        Nothing -> withFastStore' $ \db -> getGroupMembers db vr user gInfo
+        Just dmId -> do
+          when (dmId == groupMemberId' membership) $ throwChatError $ CECommandError "cannot send to self"
+          dm <- withFastStore $ \db -> getGroupMemberById db vr user dmId
+          unless (memberStatus dm == GSMemPendingApproval) $ throwChatError $ CECommandError "cannot send directly to member not pending approval"
+          pure [dm]
      sendGroupContentMessages_ user gInfo ms live itemTTL cmrs
    sendGroupContentMessages_ :: User -> GroupInfo -> [GroupMember] -> Bool -> Maybe Int -> NonEmpty ComposedMessageReq -> CM ChatResponse
    sendGroupContentMessages_ user gInfo@GroupInfo {groupId, membership} ms live itemTTL cmrs = do
@@ -3266,6 +3271,11 @@ processChatCommand' vr = \case
    getConnQueueInfo user Connection {connId, agentConnId = AgentConnId acId} = do
      msgInfo <- withFastStore' (`getLastRcvMsgInfo` connId)
      CRQueueInfo user msgInfo <$> withAgent (`getConnectionQueueInfo` acId)
+    withSendRef :: ChatRef -> (SendRef -> CM ChatResponse) -> CM ChatResponse
+    withSendRef chatRef a = case chatRef of
+      ChatRef CTDirect cId -> a $ SRDirect cId
+      ChatRef CTGroup gId -> a $ SRGroup gId Nothing
+      _ -> throwChatError $ CECommandError "not supported"

 protocolServers :: UserProtocol p => SProtocolType p -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP]) -> ([Maybe ServerOperator], [UserServer 'PSMP], [UserServer 'PXFTP])
 protocolServers p (operators, smpServers, xftpServers) = case p of
@@ -3748,7 +3758,7 @@ chatCommandP =
      "/_get chat " *> (APIGetChat <$> chatRefP <*> optional (" content=" *> strP) <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)),
      "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)),
      "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal),
-      "/_send " *> (APISendMessages <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
+      "/_send " *> (APISendMessages <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
      "/_create tag " *> (APICreateChatTag <$> jsonP),
      "/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP),
      "/_delete tag " *> (APIDeleteChatTag <$> A.decimal),
@@ -4121,6 +4131,9 @@ chatCommandP =
        ct -> ChatName ct <$> displayNameP
    chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayNameP
    chatRefP = ChatRef <$> chatTypeP <*> A.decimal
+    sendRefP =
+      (A.char '@' $> SRDirect <*> A.decimal)
+        <|> (A.char '#' $> SRGroup <*> A.decimal <*> optional (" @" *> A.decimal))
    msgCountP = A.space *> A.decimal <|> pure 10
    ciTTLDecimal = ("default" $> Nothing) <|> (Just <$> A.decimal)
    ciTTL =
@@ -78,10 +78,7 @@ where
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.IO.Class
-import Data.Aeson (FromJSON (..), ToJSON (..))
 import qualified Data.Aeson.TH as J
-import qualified Data.Attoparsec.ByteString.Char8 as A
-import qualified Data.ByteString.Char8 as B
 import Data.Functor (($>))
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty)
@@ -104,15 +101,15 @@ import Simplex.Chat.Types.UITheme
 import Simplex.Messaging.Agent.Env.SQLite (ServerRoles (..))
 import Simplex.Messaging.Agent.Protocol (ACorrId, ConnId, UserId)
 import Simplex.Messaging.Agent.Store.AgentStore (firstRow, maybeFirstRow)
-import Simplex.Messaging.Agent.Store.DB (BoolInt (..), FromField (..), ToField (..))
+import Simplex.Messaging.Agent.Store.DB (BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
 import qualified Simplex.Messaging.Crypto.Ratchet as CR
 import Simplex.Messaging.Encoding.String
-import Simplex.Messaging.Parsers (blobFieldDecoder, defaultJSON)
+import Simplex.Messaging.Parsers (defaultJSON)
 import Simplex.Messaging.Protocol (BasicAuth (..), ProtoServerWithAuth (..), ProtocolServer (..), ProtocolType (..), ProtocolTypeI (..), SProtocolType (..), SubscriptionMode)
 import Simplex.Messaging.Transport.Client (TransportHost)
-import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
+import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8)
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
@@ -316,6 +316,7 @@ CREATE TABLE user_contact_links(
  group_link_id BLOB,
  group_link_member_role TEXT NULL,
  business_address INTEGER DEFAULT 0,
+  group_link_auto_accept TEXT NULL,
  UNIQUE(user_id, local_display_name)
 );
 CREATE TABLE contact_requests(
@@ -1086,7 +1086,7 @@ instance TextEncoding GroupMemberStatus where
    "intro-inv" -> Just GSMemIntroInvited
    "accepted" -> Just GSMemAccepted
    "announced" -> Just GSMemAnnounced
-    "pending" -> Just GSMemPendingApproval
+    "pending_approval" -> Just GSMemPendingApproval
    "connected" -> Just GSMemConnected
    "complete" -> Just GSMemComplete
    "creator" -> Just GSMemCreator
@@ -1102,7 +1102,7 @@ instance TextEncoding GroupMemberStatus where
    GSMemIntroInvited -> "intro-inv"
    GSMemAccepted -> "accepted"
    GSMemAnnounced -> "announced"
-    GSMemPendingApproval -> "pending"
+    GSMemPendingApproval -> "pending_approval"
    GSMemConnected -> "connected"
    GSMemComplete -> "complete"
    GSMemCreator -> "creator"
@@ -184,6 +184,8 @@ chatGroupTests = do
    it "should send updated mentions in history" testGroupHistoryWithMentions
    describe "uniqueMsgMentions" testUniqueMsgMentions
    describe "updatedMentionNames" testUpdatedMentionNames
+  describe "group direct messages" $ do
+    it "should send group direct messages" testGroupDirectMessages

 testGroupCheckMessages :: HasCallStack => TestParams -> IO ()
 testGroupCheckMessages =
@@ -6392,3 +6394,28 @@ testUpdatedMentionNames = do
    mentionedMember name_ = CIMention {memberId = MemberId "abcd", memberRef = ciMentionMember <$> name_}
      where
        ciMentionMember name = CIMentionMember {groupMemberId = 1, displayName = name, localAlias = Nothing, memberRole = GRMember}
+
+testGroupDirectMessages :: HasCallStack => TestParams -> IO ()
+testGroupDirectMessages =
+  testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do
+    createGroup3 "team" alice bob cath
+
+    alice #> "#team 1"
+    [bob, cath] *<# "#team alice> 1"
+
+    bob #> "#team 2"
+    [alice, cath] *<# "#team bob> 2"
+
+    void $ withCCTransaction alice $ \db ->
+      DB.execute_ db "UPDATE group_members SET member_status='pending_approval' WHERE group_member_id = 2"
+
+    alice ##> "/_send #1 @2 text 3"
+    alice <# "#team 3"
+    bob <# "#team alice> 3"
+
+    void $ withCCTransaction bob $ \db ->
+      DB.execute_ db "UPDATE group_members SET member_status='pending_approval' WHERE group_member_id = 1"
+
+    bob ##> "/_send #1 @1 text 4"
+    bob <# "#team 4"
+    alice <# "#team bob> 4"