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

src/Simplex/Chat/Bot.hs

@@ -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
 

src/Simplex/Chat/Controller.hs

@@ -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

src/Simplex/Chat/Library/Commands.hs

@@ -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 =

src/Simplex/Chat/Store/Profiles.hs

@@ -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)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.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(

src/Simplex/Chat/Types.hs

@@ -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"