diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 4f89f8d047..eea606e5be 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -898,12 +898,30 @@ processChatCommand' vr = \case CTLocal -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APICreateChatTag _ _ -> withUser $ \user -> do - pure $ chatCmdError (Just user) "not implemented" - APITagChat _ _ -> withUser $ \user -> do - pure $ chatCmdError (Just user) "not implemented" - APIUntagChat _ _ -> withUser $ \user -> do - pure $ chatCmdError (Just user) "not implemented" + 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 + CTGroup -> do + ctId <- liftIO $ createChatTag db user emoji text + tagGroupChat' db user chatId ctId + _ -> 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 + CTDirect -> do + _ <- liftIO $ untagDirectChat db chatId ctId + _ <- deleteChatTagIfEmpty db user ctId + (allTags, chatTags) <- updatedDirectChatTags db user chatId + pure $ CRChatUntagged user allTags chatTags + CTGroup -> do + _ <- liftIO $ untagGroupChat db chatId ctId + _ <- deleteChatTagIfEmpty db user ctId + (allTags, chatTags) <- updatedGroupChatTags db user chatId + pure $ CRChatUntagged user allTags chatTags + _ -> pure $ chatCmdError (Just user) "not supported" APICreateChatItems folderId cms -> withUser $ \user -> createNoteFolderContentItems user folderId (L.map (,Nothing) cms) APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of @@ -7469,6 +7487,35 @@ 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 diff --git a/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs b/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs index a61c465f30..0bec48fe83 100644 --- a/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs +++ b/src/Simplex/Chat/Migrations/M20241206_chat_tags.hs @@ -23,15 +23,19 @@ CREATE TABLE chat_tags_chats ( UNIQUE(chat_tag_id, contact_id) ); -CREATE INDEX idx_chat_tags_user_id ON chat_tags_chat(user_id); +CREATE INDEX idx_chat_tags_user_id ON chat_tags(user_id); +CREATE INDEX idx_chat_tags_chat_tag_id ON chat_tags(chat_tag_id); +CREATE INDEX idx_chat_tags_chats_chat_tag_id ON chat_tags_chats(chat_tag_id); +CREATE INDEX idx_chat_tags_user_id_chat_tag_id ON chat_tags(user_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_contact_id; -DROP INDEX idx_chat_tags_group_id_contact_id; +DROP INDEX idx_chat_tags_chat_tag_id; +DROP INDEX idx_chat_tags_chats_chat_tag_id; +DROP INDEX idx_chat_tags_user_id_chat_tag_id; DROP TABLE chat_tags_chats DROP TABLE chat_tags; diff --git a/src/Simplex/Chat/Store/Profiles.hs b/src/Simplex/Chat/Store/Profiles.hs index ed24504404..536ab0f210 100644 --- a/src/Simplex/Chat/Store/Profiles.hs +++ b/src/Simplex/Chat/Store/Profiles.hs @@ -71,11 +71,11 @@ module Simplex.Chat.Store.Profiles getCommandDataByCorrId, setUserUIThemes, createChatTag, - tagChatContact, - tagChatGroup, + tagDirectChat, + tagGroupChat, deleteChatTag, - untagChatGroup, - untagChatContact, + untagGroupChat, + untagDirectChat, getUserChatTags, getTagChatsCount, ) @@ -901,45 +901,83 @@ setUserUIThemes db User {userId} uiThemes = do updatedAt <- getCurrentTime DB.execute db "UPDATE users SET ui_themes = ?, updated_at = ? WHERE user_id = ?" (uiThemes, updatedAt, userId) --- Creates a new tag for a given emoji and text if it doesn't exist createChatTag :: DB.Connection -> User -> Text -> Text -> IO ChatTagId createChatTag db User {userId} emoji text = do - putStrLn $ "Creating tag " ++ show emoji ++ show text ++ " for user " ++ show userId - pure 1 + DB.execute + db + [sql| + INSERT INTO chat_tags (user_id, chat_tag_emoji, chat_tag_text) + VALUES (?,?,?) + |] + (userId, emoji, text) + insertedRowId db --- Creates a tag for a given contact. -tagChatContact :: DB.Connection -> Contact -> ChatTagId -> IO () -tagChatContact db Contact {contactId} tId = - putStrLn $ "Tagging contact " ++ show contactId ++ " with tag " ++ show tId +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) --- Create a tag for a given group. -tagChatGroup :: DB.Connection -> GroupInfo -> ChatTagId -> IO () -tagChatGroup db GroupInfo {groupId} tId = - putStrLn $ "Tagging group " ++ show groupId ++ " with tag " ++ show 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) --- Deletes a chat tag. To be called by untag deleteChatTag :: DB.Connection -> User -> ChatTagId -> IO () deleteChatTag db User {userId} tId = - putStrLn $ "Deleted tag for user " ++ show userId ++ " tag id " ++ show tId + DB.execute + db + [sql| + DELETE FROM chat_tags + WHERE user_id = ? AND chat_tag_id = ? + |] + (userId, tId) --- Remove a tag for a given group. If no tags left for the chat tag id, delete the tag. -untagChatGroup :: DB.Connection -> GroupInfo -> ChatTagId -> IO () -untagChatGroup db GroupInfo {groupId} tId = - putStrLn $ "Untagging group " ++ show groupId ++ " tag id " ++ show 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) --- Remove a tag for a given contact. If no tags left for the chat tag id, delete the tag. -untagChatContact :: DB.Connection -> Contact -> ChatTagId -> IO () -untagChatContact db Contact {contactId} tId = - putStrLn $ "Untagging contact " ++ show contactId ++ " tag id " ++ show 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) --- Gets all chat tags for a given user getUserChatTags :: DB.Connection -> User -> IO [ChatTag] -getUserChatTags db User {userId} = do - putStrLn $ "Getting all tags for user" ++ show userId - pure [] +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} --- Gets the total number of tags with associated chats for a given user and tag. To be used to determine if a tag can be deleted when group or contact is untagged. -getTagChatsCount :: DB.Connection -> User -> ChatTagId -> IO Int -getTagChatsCount db User {userId} tagId = do - putStrLn $ "Getting tag chats count for user " ++ show userId ++ " and tag " ++ show tagId - pure 0 \ No newline at end of file +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) \ No newline at end of file