mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-03-31 09:46:03 +00:00
core, ios: chat tags (#5367)
* types and db * migration module * chat tag * store method proposal * profiles build * update type * update return type * building * working api * update * refactor * attach tags to contact * simplify * attach chat tags to group info * get chat tags with supplied user id * get tags fix * ios: chat tags poc (#5370) * ios: chat tags poc * updates to sheet * temporary display for other option on swipe * sheet height * only show preset when it has matches * changes * worst emoji picker ever * simplify tag casts and collapse * open on create tag if no tags * simple emoji text field * nice emoji picker * dismiss sheets on tag/untag * semibold selection * all preset tag and change collapsed icon on selection * default selected tag (all) * only apply tag filters on empty search * + button when no custom lists * reset selection of tag filter on profile changes * edit tag (broken menu inside swiftui list) * create list to end of list * swipe changes * remove context menu * delete and edit on swipe actions * tap unread filter deselects other filters * remove delete tag if empty * show tag creation sheet when + button pressed * in memory tag edit * color, size * frame * layout * refactor * remove code * add unread to same unit * fraction on long press * nav fixes * in memory list * emoji picker improvements * remove diff * secondary plus * stop flickering on chat tags load * reuse string * fix reset glitches * delete destructive * simplify? * changes * api updates * fix styles on list via swipe * fixed untag * update schema * move user tags loading to get users chat data * move presets to model * update preset tags when chats are updated * style fixes and locate getPresetTags near tags model --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com> * deleted contacts and card should not match contact preset * fix update presets on chat remove * update migration indices * fix migration * not used chat model * disable button on repeated list name or emoji * no chats message for search fix * fix edits and trim * error in footer, not in alert * styling fixes due to wrong place to attach sheet * update library * remove log * idea for dynamic sheet height * max fraction 62% * minor fixes * disable save button when no changes and while saving * disable preset filter if it is no longer shown * remove comments from schema * fix emoji * remove apiChatTagsResponse * always read chat tags * fix --------- Co-authored-by: Evgeny Poberezkin <evgeny@poberezkin.com> Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Diogo
@@ -847,6 +847,9 @@ processChatCommand' vr = \case
|
||||
. sortOn (timeAvg . snd)
|
||||
. M.assocs
|
||||
<$> withConnection st (readTVarIO . DB.slow)
|
||||
APIGetChatTags userId -> withUserId' userId $ \user -> do
|
||||
tags <- withFastStore' (`getUserChatTags` user)
|
||||
pure $ CRChatTags user tags
|
||||
APIGetChats {userId, pendingConnections, pagination, query} -> withUserId' userId $ \user -> do
|
||||
(errs, previews) <- partitionEithers <$> withFastStore' (\db -> getChatPreviews db vr user pendingConnections pagination query)
|
||||
unless (null errs) $ toView $ CRChatErrors (Just user) (map ChatErrorStore errs)
|
||||
@@ -894,6 +897,26 @@ 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 (ChatTagData emoji text) -> withUser $ \user -> withFastStore' $ \db -> do
|
||||
_ <- createChatTag db user emoji text
|
||||
CRChatTags user <$> getUserChatTags db user
|
||||
APISetChatTags (ChatRef cType chatId) tagIds -> withUser $ \user -> withFastStore' $ \db -> case cType of
|
||||
CTDirect -> do
|
||||
updateDirectChatTags db chatId (maybe [] L.toList tagIds)
|
||||
CRTagsUpdated user <$> getUserChatTags db user <*> getDirectChatTags db chatId
|
||||
CTGroup -> do
|
||||
updateGroupChatTags db chatId (maybe [] L.toList tagIds)
|
||||
CRTagsUpdated user <$> getUserChatTags db user <*> getGroupChatTags db chatId
|
||||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChatTag tagId -> withUser $ \user -> do
|
||||
withFastStore' $ \db -> deleteChatTag db user tagId
|
||||
ok user
|
||||
APIUpdateChatTag tagId (ChatTagData emoji text) -> withUser $ \user -> do
|
||||
withFastStore' $ \db -> updateChatTag db user tagId emoji text
|
||||
ok user
|
||||
APIReorderChatTags tagIds -> withUser $ \user -> do
|
||||
withFastStore' $ \db -> reorderChatTags db user $ L.toList tagIds
|
||||
ok user
|
||||
APICreateChatItems folderId cms -> withUser $ \user ->
|
||||
createNoteFolderContentItems user folderId (L.map (,Nothing) cms)
|
||||
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> case cType of
|
||||
@@ -8391,6 +8414,7 @@ chatCommandP =
|
||||
"/sql chat " *> (ExecChatStoreSQL <$> textP),
|
||||
"/sql agent " *> (ExecAgentStoreSQL <$> textP),
|
||||
"/sql slow" $> SlowSQLQueries,
|
||||
"/_get tags " *> (APIGetChatTags <$> A.decimal),
|
||||
"/_get chats "
|
||||
*> ( APIGetChats
|
||||
<$> A.decimal
|
||||
@@ -8402,6 +8426,11 @@ chatCommandP =
|
||||
"/_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)),
|
||||
"/_create tag " *> (APICreateChatTag <$> jsonP),
|
||||
"/_tags " *> (APISetChatTags <$> chatRefP <*> optional _strP),
|
||||
"/_delete tag " *> (APIDeleteChatTag <$> A.decimal),
|
||||
"/_update tag " *> (APIUpdateChatTag <$> A.decimal <* A.space <*> jsonP),
|
||||
"/_reorder tags " *> (APIReorderChatTags <$> strP),
|
||||
"/_create *" *> (APICreateChatItems <$> A.decimal <*> (" json " *> jsonP <|> " text " *> composedMessagesTextP)),
|
||||
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP),
|
||||
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode),
|
||||
|
||||
@@ -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)
|
||||
|
||||
47
src/Simplex/Chat/Migrations/M20241206_chat_tags.hs
Normal file
47
src/Simplex/Chat/Migrations/M20241206_chat_tags.hs
Normal file
@@ -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;
|
||||
|]
|
||||
@@ -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
|
||||
);
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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}
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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}
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -96,6 +96,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 +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
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user