refactor

src/Simplex/Chat.hs

@@ -900,27 +900,29 @@ processChatCommand' vr = \case
     CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
   APICreateChatTag (ChatRef cType chatId) (ChatTagData emoji text) -> withUser $ \user -> withFastStore $ \db -> case cType of
     CTDirect -> do
-      ctId <- liftIO $ createChatTag db user emoji text
-      tagDirectChat' db user chatId ctId
+      tId <- liftIO $ createChatTag db user emoji text
+      liftIO $ tagDirectChat db chatId tId
+      CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getDirectChatTags db chatId)
     CTGroup -> do
-      ctId <- liftIO $ createChatTag db user emoji text
-      tagGroupChat' db user chatId ctId
+      tId <- liftIO $ createChatTag db user emoji text
+      liftIO $ tagGroupChat db chatId tId
+      CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getGroupChatTags db chatId)
     _ -> pure $ chatCmdError (Just user) "not supported"
-  APITagChat (ChatRef cType chatId) ctId -> withUser $ \user -> withFastStore $ \db -> case cType of
-    CTDirect -> tagDirectChat' db user chatId ctId
-    CTGroup -> tagGroupChat' db user chatId ctId
-    _ -> pure $ chatCmdError (Just user) "not supported"
-  APIUntagChat (ChatRef cType chatId) ctId -> withUser $ \user -> withFastStore $ \db -> case cType of
+  APITagChat (ChatRef cType chatId) tId -> withUser $ \user -> withFastStore $ \db -> case cType of
     CTDirect -> do
-      _ <- liftIO $ untagDirectChat db chatId ctId
-      _ <- deleteChatTagIfEmpty db user ctId
-      (allTags, chatTags) <- updatedDirectChatTags db user chatId
-      pure $ CRChatUntagged user allTags chatTags
+      liftIO $ tagDirectChat db chatId tId
+      CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getDirectChatTags db chatId)
     CTGroup -> do
-      _ <- liftIO $ untagGroupChat db chatId ctId
-      _ <- deleteChatTagIfEmpty db user ctId
-      (allTags, chatTags) <- updatedGroupChatTags db user chatId
-      pure $ CRChatUntagged user allTags chatTags
+      liftIO $ tagGroupChat db chatId tId
+      CRTagsUpdated user <$> liftIO (getUserChatTags db user) <*> liftIO (getGroupChatTags db chatId)
+    _ -> pure $ chatCmdError (Just user) "not supported"
+  APIUntagChat (ChatRef cType chatId) tId -> withUser $ \user -> withFastStore $ \db -> case cType of
+    CTDirect -> do
+      liftIO $ untagDirectChat db user chatId tId
+      CRChatUntagged user <$> liftIO (getUserChatTags db user) <*> liftIO (getDirectChatTags db chatId)
+    CTGroup -> do
+      liftIO $ untagGroupChat db user chatId tId
+      CRChatUntagged user <$> liftIO (getUserChatTags db user) <*> liftIO (getGroupChatTags db chatId)
     _ -> pure $ chatCmdError (Just user) "not supported"
   APICreateChatItems folderId cms -> withUser $ \user ->
     createNoteFolderContentItems user folderId (L.map (,Nothing) cms)
@@ -7487,35 +7489,6 @@ closeFileHandle fileId files = do
   h_ <- atomically . stateTVar fs $ \m -> (M.lookup fileId m, M.delete fileId m)
   liftIO $ mapM_ hClose h_ `catchAll_` pure ()
 
-tagGroupChat' :: DB.Connection -> User -> GroupId -> ChatTagId -> ExceptT StoreError IO ChatResponse
-tagGroupChat' db user gId ctId = do
-  liftIO $ tagGroupChat db gId ctId
-  (allTags, chatTags) <- updatedGroupChatTags db user gId
-  pure $ CRChatTagged user allTags chatTags
-
-updatedGroupChatTags :: DB.Connection -> User -> GroupId -> ExceptT StoreError IO ([ChatTag], [ChatTag])
-updatedGroupChatTags db user gId = do
-  allTags <- liftIO $ getUserChatTags db user
-  let (groupTags, otherTags) = partition (\ChatTag {groupId} -> groupId == Just gId) allTags
-  pure (groupTags, otherTags)
-
-deleteChatTagIfEmpty :: DB.Connection -> User -> ChatTagId -> ExceptT StoreError IO ()
-deleteChatTagIfEmpty db user ctId = do
-  tagChatsCount <- liftIO $ getTagChatsCount db ctId
-  when (tagChatsCount == 0) $ liftIO $ deleteChatTag db user ctId
-
-tagDirectChat' :: DB.Connection -> User -> ContactId -> ChatTagId -> ExceptT StoreError IO ChatResponse
-tagDirectChat' db user cId ctId = do
-  liftIO $ tagDirectChat db cId ctId
-  (allTags, chatTags) <- updatedDirectChatTags db user cId
-  pure $ CRChatTagged user allTags chatTags
-
-updatedDirectChatTags :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO ([ChatTag], [ChatTag])
-updatedDirectChatTags db user cId = do
-  allTags <- liftIO $ getUserChatTags db user
-  let (directTags, otherTags) = partition (\ChatTag {contactId} -> contactId == Just cId) allTags
-  pure (directTags, otherTags)
-
 deleteMembersConnections :: User -> [GroupMember] -> CM ()
 deleteMembersConnections user members = deleteMembersConnections' user members False
 

src/Simplex/Chat/Controller.hs

@@ -622,8 +622,8 @@ 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 :: [ChatTag]}
-  | CRChatUntagged {user :: User, userTags :: [ChatTag], chatTags :: [ChatTag]}
+  | CRTagsUpdated {user :: User, userTags :: [ChatTag], chatTags :: [ChatTagId]}
+  | CRChatUntagged {user :: User, userTags :: [ChatTag], chatTags :: [ChatTagId]}
   | CRNewChatItems {user :: User, chatItems :: [AChatItem]}
   | CRChatItemsStatusesUpdated {user :: User, chatItems :: [AChatItem]}
   | CRChatItemUpdated {user :: User, chatItem :: AChatItem}

src/Simplex/Chat/Store/Direct.hs

@@ -79,6 +79,9 @@ module Simplex.Chat.Store.Direct
     setContactCustomData,
     setContactUIThemes,
     setContactChatDeleted,
+    tagDirectChat,
+    untagDirectChat,
+    getDirectChatTags,
   )
 where
 
@@ -1020,3 +1023,31 @@ 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)
+
+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 -> User -> ContactId -> ChatTagId -> IO ()
+untagDirectChat db user contactId tId = do
+  untagDirectChat' db contactId tId
+  deleteChatTagIfEmpty db user 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)

src/Simplex/Chat/Store/Groups.hs

@@ -122,6 +122,9 @@ module Simplex.Chat.Store.Groups
     updateUserMemberProfileSentAt,
     setGroupCustomData,
     setGroupUIThemes,
+    tagGroupChat,
+    untagGroupChat,
+    getGroupChatTags,
   )
 where
 
@@ -1484,16 +1487,17 @@ 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}
 
@@ -2303,3 +2307,32 @@ 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)
+
+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 -> User -> GroupId -> ChatTagId -> IO ()
+untagGroupChat db user gId tId = do
+  untagGroupChat' db gId tId
+  deleteChatTagIfEmpty db user 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)
+
+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)

src/Simplex/Chat/Store/Profiles.hs

@@ -70,14 +70,6 @@ module Simplex.Chat.Store.Profiles
     updateCommandStatus,
     getCommandDataByCorrId,
     setUserUIThemes,
-    createChatTag,
-    tagDirectChat,
-    tagGroupChat,
-    deleteChatTag,
-    untagGroupChat,
-    untagDirectChat,
-    getUserChatTags,
-    getTagChatsCount,
   )
 where
 
@@ -900,84 +892,3 @@ setUserUIThemes :: DB.Connection -> User -> Maybe UIThemeEntityOverrides -> IO (
 setUserUIThemes db User {userId} uiThemes = do
   updatedAt <- getCurrentTime
   DB.execute db "UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?" (uiThemes, updatedAt, userId)
-
-createChatTag :: DB.Connection -> User -> 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)
-      VALUES (?,?,?)
-    |]
-    (userId, emoji, text)
-  insertedRowId db
-
-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)
-
-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)
-
-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)
-
-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)
-
-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)
-
-getUserChatTags :: DB.Connection -> User -> IO [ChatTag]
-getUserChatTags db User {userId} =
-  map toChatTag
-    <$> DB.query
-      db
-      [sql|
-        SELECT t.chat_tag_id, t.chat_tag_emoji, t.chat_tag_text, ct.contact_id, ct.group_id
-        FROM chat_tags_chats ct
-        JOIN chat_tags t ON ct.chat_tag_id = t.chat_tag_id
-        WHERE t.user_id = ?
-      |]
-      (Only userId)
-  where
-    toChatTag :: (ChatTagId, Text, Text, Maybe ContactId, Maybe GroupId) -> ChatTag
-    toChatTag (chatTagId, chatTagEmoji, chatTagText, contactId, groupId) = ChatTag {chatTagId, chatTagEmoji, chatTagText, contactId, groupId}
-
-getTagChatsCount :: DB.Connection -> ChatTagId -> IO Int
-getTagChatsCount db tId =
-  fromOnly . head <$> DB.query db "SELECT COUNT(*) FROM chat_tags_chats WHERE chat_tag_id = ?" (Only tId)

src/Simplex/Chat/Store/Shared.hs

@@ -592,3 +592,48 @@ 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 -> 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)
+      VALUES (?,?,?)
+    |]
+    (userId, emoji, text)
+  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)
+
+getTagChatsCount :: DB.Connection -> ChatTagId -> IO Int
+getTagChatsCount db tId =
+  fromOnly . head <$> DB.query db "SELECT COUNT(*) FROM chat_tags_chats WHERE chat_tag_id = ?" (Only tId)
+
+deleteChatTagIfEmpty :: DB.Connection -> User -> ChatTagId -> IO ()
+deleteChatTagIfEmpty db user ctId = do
+  tagChatsCount <- getTagChatsCount db ctId
+  when (tagChatsCount == 0) $ deleteChatTag db user ctId
+
+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 = ?
+      |]
+      (Only userId)
+  where
+    toChatTag :: (ChatTagId, Text, Text) -> ChatTag
+    toChatTag (chatTagId, chatTagEmoji, chatTagText) = ChatTag {chatTagId, chatTagEmoji, chatTagText}

src/Simplex/Chat/View.hs

@@ -150,7 +150,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
-  CRChatTagged u _ _ -> ttyUser u ["chat tagged"]
+  CRTagsUpdated u _ _ -> ttyUser u ["chat tagged"]
   CRChatUntagged u _ _ -> ttyUser u ["chat untagged"]
   CRChatItemsDeleted u deletions byUser timed -> case deletions of
     [ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] ->