Merge remote-tracking branch 'origin/master' into ab/resize-image

src/Simplex/Chat/Controller.hs

@@ -294,11 +294,17 @@ data ChatCommand
   | ExecChatStoreSQL Text
   | ExecAgentStoreSQL Text
   | SlowSQLQueries
+  | APIGetChatTags UserId
   | APIGetChats {userId :: UserId, pendingConnections :: Bool, pagination :: PaginationByTime, query :: ChatListQuery}
   | APIGetChat ChatRef ChatPagination (Maybe String)
   | APIGetChatItems ChatPagination (Maybe String)
   | APIGetChatItemInfo ChatRef ChatItemId
   | APISendMessages {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessages :: NonEmpty ComposedMessage}
+  | APICreateChatTag ChatTagData
+  | APISetChatTags ChatRef (Maybe (NonEmpty ChatTagId))
+  | APIDeleteChatTag ChatTagId
+  | APIUpdateChatTag ChatTagId ChatTagData
+  | APIReorderChatTags (NonEmpty ChatTagId)
   | APICreateChatItems {noteFolderId :: NoteFolderId, composedMessages :: NonEmpty ComposedMessage}
   | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
   | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode
@@ -587,6 +593,7 @@ data ChatResponse
   | CRApiChats {user :: User, chats :: [AChat]}
   | CRChats {chats :: [AChat]}
   | CRApiChat {user :: User, chat :: AChat, navInfo :: Maybe NavigationInfo}
+  | CRChatTags {user :: User, userTags :: [ChatTag]}
   | CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
   | CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
   | CRChatItemId User (Maybe ChatItemId)
@@ -617,6 +624,7 @@ data ChatResponse
   | CRContactCode {user :: User, contact :: Contact, connectionCode :: Text}
   | CRGroupMemberCode {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionCode :: Text}
   | CRConnectionVerified {user :: User, verified :: Bool, expectedCode :: Text}
+  | CRTagsUpdated {user :: User, userTags :: [ChatTag], chatTags :: [ChatTagId]}
   | CRNewChatItems {user :: User, chatItems :: [AChatItem]}
   | CRChatItemsStatusesUpdated {user :: User, chatItems :: [AChatItem]}
   | CRChatItemUpdated {user :: User, chatItem :: AChatItem}
@@ -1068,6 +1076,16 @@ instance FromJSON ComposedMessage where
   parseJSON invalid =
     JT.prependFailure "bad ComposedMessage, " (JT.typeMismatch "Object" invalid)
 
+data ChatTagData = ChatTagData
+  { emoji :: Maybe Text,
+    text :: Text
+  }
+  deriving (Show)
+
+instance FromJSON ChatTagData where
+  parseJSON (J.Object v) = ChatTagData <$> v .:? "emoji" <*> v .: "text"
+  parseJSON invalid = JT.prependFailure "bad ChatTagData, " (JT.typeMismatch "Object" invalid)
+
 data NtfConn = NtfConn
   { user_ :: Maybe User,
     connEntity_ :: Maybe ConnectionEntity,
@@ -1603,3 +1621,5 @@ $(JQ.deriveFromJSON defaultJSON ''ArchiveConfig)
 $(JQ.deriveFromJSON defaultJSON ''DBEncryptionConfig)
 
 $(JQ.deriveToJSON defaultJSON ''ComposedMessage)
+
+$(JQ.deriveToJSON defaultJSON ''ChatTagData)

src/Simplex/Chat/Core.hs

@@ -21,11 +21,12 @@ import Data.Time.Clock (getCurrentTime)
 import Data.Time.LocalTime (getCurrentTimeZone)
 import Simplex.Chat
 import Simplex.Chat.Controller
+import Simplex.Chat.Library.Commands
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Store.Profiles
 import Simplex.Chat.Types
 import Simplex.Chat.View (serializeChatResponse)
-import Simplex.Messaging.Agent.Store.SQLite (SQLiteStore, withTransaction, MigrationConfirmation (..))
+import Simplex.Messaging.Agent.Store.SQLite (MigrationConfirmation (..), SQLiteStore, withTransaction)
 import System.Exit (exitFailure)
 import System.IO (hFlush, stdout)
 import Text.Read (readMaybe)

src/Simplex/Chat/Migrations/M20241206_chat_tags.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Migrations.M20241206_chat_tags where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20241206_chat_tags :: Query
+m20241206_chat_tags =
+  [sql|
+CREATE TABLE chat_tags (
+  chat_tag_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  user_id INTEGER REFERENCES users,
+  chat_tag_text TEXT NOT NULL,
+  chat_tag_emoji TEXT,
+  tag_order INTEGER NOT NULL
+);
+
+CREATE TABLE chat_tags_chats (
+  contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
+  group_id INTEGER REFERENCES groups ON DELETE CASCADE,
+  chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE
+);
+
+CREATE INDEX idx_chat_tags_user_id ON chat_tags(user_id);
+CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_text ON chat_tags(user_id, chat_tag_text);
+CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_emoji ON chat_tags(user_id, chat_tag_emoji);
+
+CREATE INDEX idx_chat_tags_chats_chat_tag_id ON chat_tags_chats(chat_tag_id);
+CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_contact_id ON chat_tags_chats(contact_id, chat_tag_id);
+CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_group_id ON chat_tags_chats(group_id, chat_tag_id);
+|]
+
+down_m20241206_chat_tags :: Query
+down_m20241206_chat_tags =
+  [sql|
+DROP INDEX idx_chat_tags_user_id;
+DROP INDEX idx_chat_tags_user_id_chat_tag_text;
+DROP INDEX idx_chat_tags_user_id_chat_tag_emoji;
+
+DROP INDEX idx_chat_tags_chats_chat_tag_id;
+DROP INDEX idx_chat_tags_chats_chat_tag_id_contact_id;
+DROP INDEX idx_chat_tags_chats_chat_tag_id_group_id;
+
+DROP TABLE chat_tags_chats;
+DROP TABLE chat_tags;
+|]

src/Simplex/Chat/Migrations/chat_schema.sql

@@ -623,6 +623,18 @@ CREATE TABLE operator_usage_conditions(
   accepted_at TEXT,
   created_at TEXT NOT NULL DEFAULT(datetime('now'))
 );
+CREATE TABLE chat_tags(
+  chat_tag_id INTEGER PRIMARY KEY AUTOINCREMENT,
+  user_id INTEGER REFERENCES users,
+  chat_tag_text TEXT NOT NULL,
+  chat_tag_emoji TEXT,
+  tag_order INTEGER NOT NULL
+);
+CREATE TABLE chat_tags_chats(
+  contact_id INTEGER REFERENCES contacts ON DELETE CASCADE,
+  group_id INTEGER REFERENCES groups ON DELETE CASCADE,
+  chat_tag_id INTEGER NOT NULL REFERENCES chat_tags ON DELETE CASCADE
+);
 CREATE INDEX contact_profiles_index ON contact_profiles(
   display_name,
   full_name
@@ -929,3 +941,21 @@ CREATE INDEX idx_chat_items_notes ON chat_items(
   created_at
 );
 CREATE INDEX idx_groups_business_xcontact_id ON groups(business_xcontact_id);
+CREATE INDEX idx_chat_tags_user_id ON chat_tags(user_id);
+CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_text ON chat_tags(
+  user_id,
+  chat_tag_text
+);
+CREATE UNIQUE INDEX idx_chat_tags_user_id_chat_tag_emoji ON chat_tags(
+  user_id,
+  chat_tag_emoji
+);
+CREATE INDEX idx_chat_tags_chats_chat_tag_id ON chat_tags_chats(chat_tag_id);
+CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_contact_id ON chat_tags_chats(
+  contact_id,
+  chat_tag_id
+);
+CREATE UNIQUE INDEX idx_chat_tags_chats_chat_tag_id_group_id ON chat_tags_chats(
+  group_id,
+  chat_tag_id
+);

src/Simplex/Chat/Mobile.hs

@@ -38,6 +38,7 @@ import GHC.IO.Encoding (setFileSystemEncoding, setForeignEncoding, setLocaleEnco
 import Simplex.Chat
 import Simplex.Chat.Controller
 import Simplex.Chat.Image (readResizeable, resizeImageToSize)
+import Simplex.Chat.Library.Commands
 import Simplex.Chat.Markdown (ParsedMarkdown (..), parseMaybeMarkdownList)
 import Simplex.Chat.Mobile.File
 import Simplex.Chat.Mobile.Shared

src/Simplex/Chat/Store/Connections.hs

@@ -21,11 +21,14 @@ where
 import Control.Applicative ((<|>))
 import Control.Monad
 import Control.Monad.Except
+import Control.Monad.IO.Class
+import Data.Bitraversable (bitraverse)
 import Data.Int (Int64)
 import Data.Maybe (catMaybes, fromMaybe)
 import Database.SQLite.Simple (Only (..), (:.) (..))
 import Database.SQLite.Simple.QQ (sql)
 import Simplex.Chat.Protocol
+import Simplex.Chat.Store.Direct
 import Simplex.Chat.Store.Files
 import Simplex.Chat.Store.Groups
 import Simplex.Chat.Store.Profiles
@@ -93,8 +96,9 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
           (userId, agentConnId)
     getContactRec_ :: Int64 -> Connection -> ExceptT StoreError IO Contact
     getContactRec_ contactId c = ExceptT $ do
-      toContact' contactId c
-        <$> DB.query
+      chatTags <- getDirectChatTags db contactId
+      firstRow (toContact' contactId c chatTags) (SEInternalError "referenced contact not found") $
+        DB.query
           db
           [sql|
             SELECT
@@ -105,17 +109,16 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
             WHERE c.user_id = ? AND c.contact_id = ? AND c.deleted = 0
           |]
           (userId, contactId)
-    toContact' :: Int64 -> Connection -> [ContactRow'] -> Either StoreError Contact
-    toContact' contactId conn [(profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)] =
+    toContact' :: Int64 -> Connection -> [ChatTagId] -> ContactRow' -> Contact
+    toContact' contactId conn chatTags ((profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) =
       let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
           chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
           mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
           activeConn = Just conn
-       in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData}
-    toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
+       in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, chatTags, uiThemes, chatDeleted, customData}
     getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
-    getGroupAndMember_ groupMemberId c = ExceptT $ do
-      firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $
+    getGroupAndMember_ groupMemberId c = do
+      gm <- ExceptT $ firstRow (toGroupAndMember c) (SEInternalError "referenced group member not found") $
         DB.query
           db
           [sql|
@@ -141,9 +144,10 @@ getConnectionEntity db vr user@User {userId, userContactId} agentConnId = do
             WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
           |]
           (groupMemberId, userId, userContactId)
+      liftIO $ bitraverse (addGroupChatTags db) pure gm
     toGroupAndMember :: Connection -> GroupInfoRow :. GroupMemberRow -> (GroupInfo, GroupMember)
     toGroupAndMember c (groupInfoRow :. memberRow) =
-      let groupInfo = toGroupInfo vr userContactId groupInfoRow
+      let groupInfo = toGroupInfo vr userContactId [] groupInfoRow
           member = toGroupMember userContactId memberRow
        in (groupInfo, (member :: GroupMember) {activeConn = Just c})
     getConnSndFileTransfer_ :: Int64 -> Connection -> ExceptT StoreError IO SndFileTransfer

src/Simplex/Chat/Store/Direct.hs

@@ -79,6 +79,8 @@ module Simplex.Chat.Store.Direct
     setContactCustomData,
     setContactUIThemes,
     setContactChatDeleted,
+    getDirectChatTags,
+    updateDirectChatTags,
   )
 where
 
@@ -180,8 +182,8 @@ getConnReqContactXContactId db vr user@User {userId} cReqHash = do
           (userId, cReqHash)
 
 getContactByConnReqHash :: DB.Connection -> VersionRangeChat -> User -> ConnReqUriHash -> IO (Maybe Contact)
-getContactByConnReqHash db vr user@User {userId} cReqHash =
-  maybeFirstRow (toContact vr user) $
+getContactByConnReqHash db vr user@User {userId} cReqHash = do
+  ct_ <- maybeFirstRow (toContact vr user []) $
     DB.query
       db
       [sql|
@@ -201,6 +203,7 @@ getContactByConnReqHash db vr user@User {userId} cReqHash =
         LIMIT 1
       |]
       (userId, cReqHash, CSActive)
+  mapM (addDirectChatTags db) ct_
 
 createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> VersionChat -> PQSupport -> IO PendingContactConnection
 createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode chatV pqSup = do
@@ -251,6 +254,7 @@ createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p
         chatTs = Just currentTs,
         contactGroupMemberId = Nothing,
         contactGrpInvSent = False,
+        chatTags = [],
         uiThemes = Nothing,
         chatDeleted = False,
         customData = Nothing
@@ -636,8 +640,8 @@ createOrUpdateContactRequest db vr user@User {userId, userContactId} userContact
             )
           insertedRowId db
     getContact' :: XContactId -> IO (Maybe Contact)
-    getContact' xContactId =
-      maybeFirstRow (toContact vr user) $
+    getContact' xContactId = do
+      ct_ <- maybeFirstRow (toContact vr user []) $
         DB.query
           db
           [sql|
@@ -657,13 +661,15 @@ createOrUpdateContactRequest db vr user@User {userId, userContactId} userContact
             LIMIT 1
           |]
           (userId, xContactId)
+      mapM (addDirectChatTags db) ct_
     getGroupInfo' :: XContactId -> IO (Maybe GroupInfo)
-    getGroupInfo' xContactId =
-      maybeFirstRow (toGroupInfo vr userContactId) $
+    getGroupInfo' xContactId = do
+      g_ <- maybeFirstRow (toGroupInfo vr userContactId []) $
         DB.query
           db
           (groupInfoQuery <> " WHERE g.business_xcontact_id = ? AND g.user_id = ? AND mu.contact_id = ?")
           (xContactId, userId, userContactId)
+      mapM (addGroupChatTags db) g_
     getContactRequestByXContactId :: XContactId -> IO (Maybe UserContactRequest)
     getContactRequestByXContactId xContactId =
       maybeFirstRow toContactRequest $
@@ -819,6 +825,7 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}
             chatTs = Just createdAt,
             contactGroupMemberId = Nothing,
             contactGrpInvSent = False,
+            chatTags = [],
             uiThemes = Nothing,
             chatDeleted = False,
             customData = Nothing
@@ -845,8 +852,9 @@ getContact :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT Stor
 getContact db vr user contactId = getContact_ db vr user contactId False
 
 getContact_ :: DB.Connection -> VersionRangeChat -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
-getContact_ db vr user@User {userId} contactId deleted =
-  ExceptT . firstRow (toContact vr user) (SEContactNotFound contactId) $
+getContact_ db vr user@User {userId} contactId deleted = do
+  chatTags <- liftIO $ getDirectChatTags db contactId
+  ExceptT . firstRow (toContact vr user chatTags) (SEContactNotFound contactId) $
     DB.query
       db
       [sql|
@@ -1018,3 +1026,39 @@ setContactChatDeleted :: DB.Connection -> User -> Contact -> Bool -> IO ()
 setContactChatDeleted db User {userId} Contact {contactId} chatDeleted = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE contacts SET chat_deleted = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" (chatDeleted, updatedAt, userId, contactId)
+
+updateDirectChatTags :: DB.Connection -> ContactId -> [ChatTagId] -> IO ()
+updateDirectChatTags db contactId tIds = do
+  currentTags <- getDirectChatTags db contactId
+  let tagsToAdd = filter (`notElem` currentTags) tIds
+      tagsToDelete = filter (`notElem` tIds) currentTags
+  forM_ tagsToDelete $ untagDirectChat db contactId
+  forM_ tagsToAdd $ tagDirectChat db contactId
+
+tagDirectChat :: DB.Connection -> ContactId -> ChatTagId -> IO ()
+tagDirectChat db contactId tId =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO chat_tags_chats (contact_id, chat_tag_id)
+      VALUES (?,?)
+    |]
+    (contactId, tId)
+
+untagDirectChat :: DB.Connection -> ContactId -> ChatTagId -> IO ()
+untagDirectChat db contactId tId =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM chat_tags_chats
+      WHERE contact_id = ? AND chat_tag_id = ?
+    |]
+    (contactId, tId)
+
+getDirectChatTags :: DB.Connection -> ContactId -> IO [ChatTagId]
+getDirectChatTags db contactId = map fromOnly <$> DB.query db "SELECT chat_tag_id FROM chat_tags_chats WHERE contact_id = ?" (Only contactId)
+
+addDirectChatTags :: DB.Connection -> Contact -> IO Contact
+addDirectChatTags db ct = do
+  chatTags <- getDirectChatTags db $ contactId' ct
+  pure (ct :: Contact) {chatTags}

src/Simplex/Chat/Store/Groups.hs

@@ -122,6 +122,8 @@ module Simplex.Chat.Store.Groups
     updateUserMemberProfileSentAt,
     setGroupCustomData,
     setGroupUIThemes,
+    updateGroupChatTags,
+    getGroupChatTags,
   )
 where
 
@@ -130,6 +132,7 @@ import Control.Monad.Except
 import Control.Monad.IO.Class
 import Crypto.Random (ChaChaDRG)
 import Data.Bifunctor (second)
+import Data.Bitraversable (bitraverse)
 import Data.Either (rights)
 import Data.Int (Int64)
 import Data.List (partition, sortOn)
@@ -249,8 +252,8 @@ setGroupLinkMemberRole db User {userId} userContactLinkId memberRole =
   DB.execute db "UPDATE user_contact_links SET group_link_member_role = ? WHERE user_id = ? AND user_contact_link_id = ?" (memberRole, userId, userContactLinkId)
 
 getGroupAndMember :: DB.Connection -> User -> Int64 -> VersionRangeChat -> ExceptT StoreError IO (GroupInfo, GroupMember)
-getGroupAndMember db User {userId, userContactId} groupMemberId vr =
-  ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
+getGroupAndMember db User {userId, userContactId} groupMemberId vr = do
+  gm <- ExceptT . firstRow toGroupAndMember (SEInternalError "referenced group member not found") $
     DB.query
       db
       [sql|
@@ -285,10 +288,11 @@ getGroupAndMember db User {userId, userContactId} groupMemberId vr =
         WHERE m.group_member_id = ? AND g.user_id = ? AND mu.contact_id = ?
       |]
       (userId, groupMemberId, userId, userContactId)
+  liftIO $ bitraverse (addGroupChatTags db) pure gm
   where
     toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
     toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
-      let groupInfo = toGroupInfo vr userContactId groupInfoRow
+      let groupInfo = toGroupInfo vr userContactId [] groupInfoRow
           member = toGroupMember userContactId memberRow
        in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow})
 
@@ -333,6 +337,7 @@ createNewGroup db vr gVar user@User {userId} groupProfile incognitoProfile = Exc
           updatedAt = currentTs,
           chatTs = Just currentTs,
           userMemberProfileSentAt = Just currentTs,
+          chatTags = [],
           uiThemes = Nothing,
           customData = Nothing
         }
@@ -401,6 +406,7 @@ createGroupInvitation db vr user@User {userId} contact@Contact {contactId, activ
                   updatedAt = currentTs,
                   chatTs = Just currentTs,
                   userMemberProfileSentAt = Just currentTs,
+                  chatTags = [],
                   uiThemes = Nothing,
                   customData = Nothing
                 },
@@ -624,8 +630,8 @@ getUserGroups db vr user@User {userId} = do
   rights <$> mapM (runExceptT . getGroup db vr user) groupIds
 
 getUserGroupDetails :: DB.Connection -> VersionRangeChat -> User -> Maybe ContactId -> Maybe String -> IO [GroupInfo]
-getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
-  map (toGroupInfo vr userContactId)
+getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ = do
+  g_ <- map (toGroupInfo vr userContactId [])
     <$> DB.query
       db
       [sql|
@@ -643,6 +649,7 @@ getUserGroupDetails db vr User {userId, userContactId} _contactId_ search_ =
           AND (gp.display_name LIKE '%' || ? || '%' OR gp.full_name LIKE '%' || ? || '%' OR gp.description LIKE '%' || ? || '%')
       |]
       (userId, userContactId, search, search, search)
+  mapM (addGroupChatTags db) g_
   where
     search = fromMaybe "" search_
 
@@ -1362,8 +1369,8 @@ createMemberConnection_ db userId groupMemberId agentConnId chatV peerChatVRange
   createConnection_ db userId ConnMember (Just groupMemberId) agentConnId ConnNew chatV peerChatVRange viaContact Nothing Nothing connLevel currentTs subMode PQSupportOff
 
 getViaGroupMember :: DB.Connection -> VersionRangeChat -> User -> Contact -> IO (Maybe (GroupInfo, GroupMember))
-getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
-  maybeFirstRow toGroupAndMember $
+getViaGroupMember db vr User {userId, userContactId} Contact {contactId} = do
+  gm_ <- maybeFirstRow toGroupAndMember $
     DB.query
       db
       [sql|
@@ -1399,10 +1406,11 @@ getViaGroupMember db vr User {userId, userContactId} Contact {contactId} =
         WHERE ct.user_id = ? AND ct.contact_id = ? AND mu.contact_id = ? AND ct.deleted = 0
       |]
       (userId, userId, contactId, userContactId)
+  mapM (bitraverse (addGroupChatTags db) pure) gm_
   where
     toGroupAndMember :: (GroupInfoRow :. GroupMemberRow :. MaybeConnectionRow) -> (GroupInfo, GroupMember)
     toGroupAndMember (groupInfoRow :. memberRow :. connRow) =
-      let groupInfo = toGroupInfo vr userContactId groupInfoRow
+      let groupInfo = toGroupInfo vr userContactId [] groupInfoRow
           member = toGroupMember userContactId memberRow
        in (groupInfo, (member :: GroupMember) {activeConn = toMaybeConnection vr connRow})
 
@@ -1482,22 +1490,24 @@ updateGroupProfileFromMember db user g@GroupInfo {groupId} Profile {displayName
   updateGroupProfile db user g' p'
   where
     getGroupProfile =
-      ExceptT $ firstRow toGroupProfile (SEGroupNotFound groupId) $
-        DB.query
-          db
-          [sql|
+      ExceptT $
+        firstRow toGroupProfile (SEGroupNotFound groupId) $
+          DB.query
+            db
+            [sql|
             SELECT gp.display_name, gp.full_name, gp.description, gp.image, gp.preferences
             FROM group_profiles gp
             JOIN groups g ON gp.group_profile_id = g.group_profile_id
             WHERE g.group_id = ?
           |]
-          (Only groupId)
+            (Only groupId)
     toGroupProfile (displayName, fullName, description, image, groupPreferences) =
       GroupProfile {displayName, fullName, description, image, groupPreferences}
 
 getGroupInfo :: DB.Connection -> VersionRangeChat -> User -> Int64 -> ExceptT StoreError IO GroupInfo
-getGroupInfo db vr User {userId, userContactId} groupId =
-  ExceptT . firstRow (toGroupInfo vr userContactId) (SEGroupNotFound groupId) $
+getGroupInfo db vr User {userId, userContactId} groupId = ExceptT $ do
+  chatTags <- getGroupChatTags db groupId
+  firstRow (toGroupInfo vr userContactId chatTags) (SEGroupNotFound groupId) $
     DB.query
       db
       (groupInfoQuery <> " WHERE g.group_id = ? AND g.user_id = ? AND mu.contact_id = ?")
@@ -2053,7 +2063,7 @@ createMemberContact
               quotaErrCounter = 0
             }
         mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
-    pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, uiThemes = Nothing, chatDeleted = False, customData = Nothing}
+    pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False, chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing}
 
 getMemberContact :: DB.Connection -> VersionRangeChat -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
 getMemberContact db vr user contactId = do
@@ -2090,7 +2100,7 @@ createMemberContactInvited
     contactId <- createContactUpdateMember currentTs userPreferences
     ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode
     let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
-        mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, uiThemes = Nothing, chatDeleted = False, customData = Nothing}
+        mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = Just ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False, chatTags = [], uiThemes = Nothing, chatDeleted = False, customData = Nothing}
         m' = m {memberContactId = Just contactId}
     pure (mCt', m')
     where
@@ -2301,3 +2311,31 @@ setGroupUIThemes :: DB.Connection -> User -> GroupInfo -> Maybe UIThemeEntityOve
 setGroupUIThemes db User {userId} GroupInfo {groupId} uiThemes = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE groups SET ui_themes = ?, updated_at = ? WHERE user_id = ? AND group_id = ?" (uiThemes, updatedAt, userId, groupId)
+
+updateGroupChatTags :: DB.Connection -> GroupId -> [ChatTagId] -> IO ()
+updateGroupChatTags db gId tIds = do
+  currentTags <- getGroupChatTags db gId
+  let tagsToAdd = filter (`notElem` currentTags) tIds
+      tagsToDelete = filter (`notElem` tIds) currentTags
+  forM_ tagsToDelete $ untagGroupChat db gId
+  forM_ tagsToAdd $ tagGroupChat db gId
+
+tagGroupChat :: DB.Connection -> GroupId -> ChatTagId -> IO ()
+tagGroupChat db groupId tId =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO chat_tags_chats (group_id, chat_tag_id)
+      VALUES (?,?)
+    |]
+    (groupId, tId)
+
+untagGroupChat :: DB.Connection -> GroupId -> ChatTagId -> IO ()
+untagGroupChat db groupId tId =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM chat_tags_chats
+      WHERE group_id = ? AND chat_tag_id = ?
+    |]
+    (groupId, tId)

src/Simplex/Chat/Store/Migrations.hs

@@ -119,6 +119,7 @@ import Simplex.Chat.Migrations.M20241027_server_operators
 import Simplex.Chat.Migrations.M20241125_indexes
 import Simplex.Chat.Migrations.M20241128_business_chats
 import Simplex.Chat.Migrations.M20241205_business_chat_members
+import Simplex.Chat.Migrations.M20241206_chat_tags
 import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
 
 schemaMigrations :: [(String, Query, Maybe Query)]
@@ -237,7 +238,8 @@ schemaMigrations =
     ("20241027_server_operators", m20241027_server_operators, Just down_m20241027_server_operators),
     ("20241125_indexes", m20241125_indexes, Just down_m20241125_indexes),
     ("20241128_business_chats", m20241128_business_chats, Just down_m20241128_business_chats),
-    ("20241205_business_chat_members", m20241205_business_chat_members, Just down_m20241205_business_chat_members)
+    ("20241205_business_chat_members", m20241205_business_chat_members, Just down_m20241205_business_chat_members),
+    ("20241206_chat_tags", m20241206_chat_tags, Just down_m20241206_chat_tags)
   ]
 
 -- | The list of migrations in ascending order by date

src/Simplex/Chat/Store/Shared.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
 
 module Simplex.Chat.Store.Shared where
 
@@ -391,14 +392,14 @@ type ContactRow' = (ProfileId, ContactName, Maybe Int64, ContactName, Text, Mayb
 
 type ContactRow = Only ContactId :. ContactRow'
 
-toContact :: VersionRangeChat -> User -> ContactRow :. MaybeConnectionRow -> Contact
-toContact vr user ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) :. connRow) =
+toContact :: VersionRangeChat -> User -> [ChatTagId] -> ContactRow :. MaybeConnectionRow -> Contact
+toContact vr user chatTags ((Only contactId :. (profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs) :. (contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData)) :. connRow) =
   let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
       activeConn = toMaybeConnection vr connRow
       chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
       incognito = maybe False connIncognito activeConn
       mergedPreferences = contactUserPreferences user userPreferences preferences incognito
-   in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, uiThemes, chatDeleted, customData}
+   in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent, chatTags, uiThemes, chatDeleted, customData}
 
 getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
 getProfileById db userId profileId =
@@ -552,14 +553,14 @@ type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageD
 
 type GroupMemberRow = ((Int64, Int64, MemberId, VersionChat, VersionChat, GroupMemberRole, GroupMemberCategory, GroupMemberStatus, Bool, Maybe MemberRestrictionStatus) :. (Maybe Int64, Maybe GroupMemberId, ContactName, Maybe ContactId, ProfileId, ProfileId, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Preferences))
 
-toGroupInfo :: VersionRangeChat -> Int64 -> GroupInfoRow -> GroupInfo
-toGroupInfo vr userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. businessRow :. (uiThemes, customData) :. userMemberRow) =
+toGroupInfo :: VersionRangeChat -> Int64 -> [ChatTagId] -> GroupInfoRow -> GroupInfo
+toGroupInfo vr userContactId chatTags ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, sendRcpts, favorite, groupPreferences) :. (createdAt, updatedAt, chatTs, userMemberProfileSentAt) :. businessRow :. (uiThemes, customData) :. userMemberRow) =
   let membership = (toGroupMember userContactId userMemberRow) {memberChatVRange = vr}
       chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
       fullGroupPreferences = mergeGroupPreferences groupPreferences
       groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences}
       businessChat = toBusinessChatInfo businessRow
-   in GroupInfo {groupId, localDisplayName, groupProfile, businessChat, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, uiThemes, customData}
+   in GroupInfo {groupId, localDisplayName, groupProfile, businessChat, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt, chatTs, userMemberProfileSentAt, chatTags, uiThemes, customData}
 
 toGroupMember :: Int64 -> GroupMemberRow -> GroupMember
 toGroupMember userContactId ((groupMemberId, groupId, memberId, minVer, maxVer, memberRole, memberCategory, memberStatus, showMessages, memberRestriction_) :. (invitedById, invitedByGroupMemberId, localDisplayName, memberContactId, memberContactProfileId, profileId, displayName, fullName, image, contactLink, localAlias, preferences)) =
@@ -592,3 +593,76 @@ groupInfoQuery =
     JOIN group_members mu ON mu.group_id = g.group_id
     JOIN contact_profiles pu ON pu.contact_profile_id = COALESCE(mu.member_profile_id, mu.contact_profile_id)
   |]
+
+createChatTag :: DB.Connection -> User -> Maybe Text -> Text -> IO ChatTagId
+createChatTag db User {userId} emoji text = do
+  DB.execute
+    db
+    [sql|
+      INSERT INTO chat_tags (user_id, chat_tag_emoji, chat_tag_text, tag_order)
+      VALUES (?,?,?, COALESCE((SELECT MAX(tag_order) + 1 FROM chat_tags WHERE user_id = ?), 1))
+    |]
+    (userId, emoji, text, userId)
+  insertedRowId db
+
+deleteChatTag :: DB.Connection -> User -> ChatTagId -> IO ()
+deleteChatTag db User {userId} tId =
+  DB.execute
+    db
+    [sql|
+      DELETE FROM chat_tags
+      WHERE user_id = ? AND chat_tag_id = ?
+    |]
+    (userId, tId)
+
+updateChatTag :: DB.Connection -> User -> ChatTagId -> Maybe Text -> Text -> IO ()
+updateChatTag db User {userId} tId emoji text =
+  DB.execute
+    db
+    [sql|
+      UPDATE chat_tags
+      SET chat_tag_emoji = ?, chat_tag_text = ?
+      WHERE user_id = ? AND chat_tag_id = ?
+    |]
+    (emoji, text, userId, tId)
+
+updateChatTagOrder :: DB.Connection -> User -> ChatTagId -> Int -> IO ()
+updateChatTagOrder db User {userId} tId order =
+  DB.execute
+    db
+    [sql|
+      UPDATE chat_tags
+      SET tag_order = ?
+      WHERE user_id = ? AND chat_tag_id = ?
+    |]
+    (order, userId, tId)
+
+reorderChatTags :: DB.Connection -> User -> [ChatTagId] -> IO ()
+reorderChatTags db user tIds =
+  forM_ (zip [1 ..] tIds) $ \(order, tId) ->
+    updateChatTagOrder db user tId order
+
+getUserChatTags :: DB.Connection -> User -> IO [ChatTag]
+getUserChatTags db User {userId} =
+  map toChatTag
+    <$> DB.query
+      db
+      [sql|
+        SELECT chat_tag_id, chat_tag_emoji, chat_tag_text
+        FROM chat_tags
+        WHERE user_id = ?
+        ORDER BY tag_order
+      |]
+      (Only userId)
+  where
+    toChatTag :: (ChatTagId, Maybe Text, Text) -> ChatTag
+    toChatTag (chatTagId, chatTagEmoji, chatTagText) = ChatTag {chatTagId, chatTagEmoji, chatTagText}
+
+getGroupChatTags :: DB.Connection -> GroupId -> IO [ChatTagId]
+getGroupChatTags db groupId =
+  map fromOnly <$> DB.query db "SELECT chat_tag_id FROM chat_tags_chats WHERE group_id = ?" (Only groupId)
+
+addGroupChatTags :: DB.Connection -> GroupInfo -> IO GroupInfo
+addGroupChatTags db g@GroupInfo {groupId} = do
+  chatTags <- getGroupChatTags db groupId
+  pure (g :: GroupInfo) {chatTags}

src/Simplex/Chat/Terminal.hs

@@ -14,10 +14,11 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Database.SQLite.Simple (SQLError (..))
 import qualified Database.SQLite.Simple as DB
-import Simplex.Chat (_defaultNtfServers, defaultChatConfig, operatorSimpleXChat)
+import Simplex.Chat (defaultChatConfig, operatorSimpleXChat)
 import Simplex.Chat.Controller
 import Simplex.Chat.Core
 import Simplex.Chat.Help (chatWelcome)
+import Simplex.Chat.Library.Commands (_defaultNtfServers)
 import Simplex.Chat.Operators
 import Simplex.Chat.Options
 import Simplex.Chat.Terminal.Input

src/Simplex/Chat/Terminal/Input.hs

@@ -29,8 +29,8 @@ import Database.SQLite.Simple (Only (..))
 import qualified Database.SQLite.Simple as SQL
 import Database.SQLite.Simple.QQ (sql)
 import GHC.Weak (deRefWeak)
-import Simplex.Chat
 import Simplex.Chat.Controller
+import Simplex.Chat.Library.Commands
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Styled

src/Simplex/Chat/Terminal/Output.hs

@@ -21,8 +21,8 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Clock (getCurrentTime)
 import Data.Time.LocalTime (getCurrentTimeZone)
-import Simplex.Chat (execChatCommand, processChatCommand)
 import Simplex.Chat.Controller
+import Simplex.Chat.Library.Commands (execChatCommand, processChatCommand)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages
 import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..))

src/Simplex/Chat/Types.hs

@@ -160,6 +160,8 @@ type ContactId = Int64
 
 type ProfileId = Int64
 
+type ChatTagId = Int64
+
 data Contact = Contact
   { contactId :: ContactId,
     localDisplayName :: ContactName,
@@ -176,6 +178,7 @@ data Contact = Contact
     chatTs :: Maybe UTCTime,
     contactGroupMemberId :: Maybe GroupMemberId,
     contactGrpInvSent :: Bool,
+    chatTags :: [ChatTagId],
     uiThemes :: Maybe UIThemeEntityOverrides,
     chatDeleted :: Bool,
     customData :: Maybe CustomData
@@ -380,6 +383,7 @@ data GroupInfo = GroupInfo
     updatedAt :: UTCTime,
     chatTs :: Maybe UTCTime,
     userMemberProfileSentAt :: Maybe UTCTime,
+    chatTags :: [ChatTagId],
     uiThemes :: Maybe UIThemeEntityOverrides,
     customData :: Maybe CustomData
   }
@@ -1637,6 +1641,13 @@ data CommandData = CommandData
   }
   deriving (Show)
 
+data ChatTag = ChatTag
+  { chatTagId :: Int64,
+    chatTagText :: Text,
+    chatTagEmoji :: Maybe Text
+  }
+  deriving (Show)
+
 -- ad-hoc type for data required for XGrpMemIntro continuation
 data XGrpMemIntroCont = XGrpMemIntroCont
   { groupId :: GroupId,
@@ -1791,3 +1802,5 @@ $(JQ.deriveJSON defaultJSON ''Contact)
 $(JQ.deriveJSON defaultJSON ''ContactRef)
 
 $(JQ.deriveJSON defaultJSON ''NoteFolder)
+
+$(JQ.deriveJSON defaultJSON ''ChatTag)

src/Simplex/Chat/View.hs

@@ -36,10 +36,11 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
 import qualified Data.Version as V
 import qualified Network.HTTP.Types as Q
 import Numeric (showFFloat)
-import Simplex.Chat (defaultChatConfig, maxImageSize)
+import Simplex.Chat (defaultChatConfig)
 import Simplex.Chat.Call
 import Simplex.Chat.Controller
 import Simplex.Chat.Help
+import Simplex.Chat.Library.Commands (maxImageSize)
 import Simplex.Chat.Markdown
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
@@ -96,6 +97,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
   CRApiChats u chats -> ttyUser u $ if testView then testViewChats chats else [viewJSON chats]
   CRChats chats -> viewChats ts tz chats
   CRApiChat u chat _ -> ttyUser u $ if testView then testViewChat chat else [viewJSON chat]
+  CRChatTags u tags -> ttyUser u $ [viewJSON tags]
   CRApiParsedMarkdown ft -> [viewJSON ft]
   CRServerTestResult u srv testFailure -> ttyUser u $ viewServerTestResult srv testFailure
   CRServerOperatorConditions (ServerOperatorConditions ops _ ca) -> viewServerOperators ops ca
@@ -149,6 +151,7 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe
     | otherwise -> []
   CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz
   CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci
+  CRTagsUpdated u _ _ -> ttyUser u ["chat tags updated"]
   CRChatItemsDeleted u deletions byUser timed -> case deletions of
     [ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] ->
       ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView