mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
core: group links (#1194)
This commit is contained in:
JRoberts
GitHub
+96
-34
@@ -485,6 +485,7 @@ processChatCommand = \case
|
||||
withChatLock . procCmd $ do
|
||||
forM_ filesInfo $ \fileInfo -> deleteFile user fileInfo
|
||||
when (memberActive membership) . void $ sendGroupMessage gInfo members XGrpDel
|
||||
deleteGroupLink' user gInfo `catchError` \_ -> pure ()
|
||||
forM_ members $ deleteMemberConnection user
|
||||
-- functions below are called in separate transactions to prevent crashes on android
|
||||
-- (possibly, race condition on integrity check?)
|
||||
@@ -522,7 +523,11 @@ processChatCommand = \case
|
||||
CTContactRequest -> pure $ chatCmdError "not supported"
|
||||
APIAcceptContact connReqId -> withUser $ \user@User {userId} -> withChatLock $ do
|
||||
cReq <- withStore $ \db -> getContactRequest db userId connReqId
|
||||
procCmd $ CRAcceptingContactRequest <$> acceptContactRequest user cReq
|
||||
-- [incognito] generate profile to send, create connection with incognito profile
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
ct <- acceptContactRequest user cReq incognitoProfile
|
||||
pure $ CRAcceptingContactRequest ct
|
||||
APIRejectContact connReqId -> withUser $ \User {userId} -> withChatLock $ do
|
||||
cReq@UserContactRequest {agentContactConnId = AgentConnId connId, agentInvitationId = AgentInvId invId} <-
|
||||
withStore $ \db ->
|
||||
@@ -737,15 +742,15 @@ processChatCommand = \case
|
||||
withStore $ \db -> createUserContactLink db userId connId cReq
|
||||
pure $ CRUserContactLinkCreated cReq
|
||||
DeleteMyAddress -> withUser $ \user -> withChatLock $ do
|
||||
conns <- withStore (`getUserContactLinkConnections` user)
|
||||
conns <- withStore (`getUserAddressConnections` user)
|
||||
procCmd $ do
|
||||
forM_ conns $ \conn -> deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
|
||||
withStore' (`deleteUserContactLink` user)
|
||||
withStore' (`deleteUserAddress` user)
|
||||
pure CRUserContactLinkDeleted
|
||||
ShowMyAddress -> withUser $ \User {userId} ->
|
||||
uncurry3 CRUserContactLink <$> withStore (`getUserContactLink` userId)
|
||||
uncurry3 CRUserContactLink <$> withStore (`getUserAddress` userId)
|
||||
AddressAutoAccept onOff msgContent -> withUser $ \User {userId} -> do
|
||||
uncurry3 CRUserContactLinkUpdated <$> withStore (\db -> updateUserContactLinkAutoAccept db userId onOff msgContent)
|
||||
uncurry3 CRUserContactLinkUpdated <$> withStore (\db -> updateUserAddressAutoAccept db userId onOff msgContent)
|
||||
AcceptContact cName -> withUser $ \User {userId} -> do
|
||||
connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName
|
||||
processChatCommand $ APIAcceptContact connReqId
|
||||
@@ -885,6 +890,7 @@ processChatCommand = \case
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
|
||||
-- TODO delete direct connections that were unused
|
||||
deleteGroupLink' user gInfo `catchError` \_ -> pure ()
|
||||
forM_ members $ deleteMemberConnection user
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemLeft
|
||||
pure $ CRLeftMemberUser gInfo {membership = membership {memberStatus = GSMemLeft}}
|
||||
@@ -929,6 +935,30 @@ processChatCommand = \case
|
||||
UpdateGroupProfile gName profile -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIUpdateGroupProfile groupId profile
|
||||
APICreateGroupLink groupId -> withUser $ \user -> withChatLock $ do
|
||||
gInfo@GroupInfo {membership = membership@GroupMember {memberRole = userRole}} <- withStore $ \db -> getGroupInfo db user groupId
|
||||
when (userRole < GRAdmin) $ throwChatError CEGroupUserRole
|
||||
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo)
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
(connId, cReq) <- withAgent $ \a -> createConnection a True SCMContact
|
||||
withStore $ \db -> createGroupLink db user gInfo connId cReq
|
||||
pure $ CRGroupLinkCreated gInfo cReq
|
||||
APIDeleteGroupLink groupId -> withUser $ \user -> withChatLock $ do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
deleteGroupLink' user gInfo
|
||||
pure $ CRGroupLinkDeleted gInfo
|
||||
APIGetGroupLink groupId -> withUser $ \user -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
CRGroupLink gInfo <$> withStore (\db -> getGroupLink db user gInfo)
|
||||
CreateGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APICreateGroupLink groupId
|
||||
DeleteGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIDeleteGroupLink groupId
|
||||
ShowGroupLink gName -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
processChatCommand $ APIGetGroupLink groupId
|
||||
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName (safeDecodeUtf8 quotedMsg)
|
||||
@@ -1108,15 +1138,16 @@ processChatCommand = \case
|
||||
groupId <- getGroupIdByName db user gName
|
||||
groupMemberId <- getGroupMemberIdByName db user groupId groupMemberName
|
||||
pure (groupId, groupMemberId)
|
||||
sendGrpInvitation :: User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> m ()
|
||||
sendGrpInvitation user ct@Contact {localDisplayName} GroupInfo {groupId, groupProfile, membership} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
|
||||
msg <- sendDirectContactMessage ct $ XGrpInv groupInv
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg content Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
setActive $ ActiveG localDisplayName
|
||||
|
||||
sendGrpInvitation :: ChatMonad m => User -> Contact -> GroupInfo -> GroupMember -> ConnReqInvitation -> m ()
|
||||
sendGrpInvitation user ct@Contact {localDisplayName} GroupInfo {groupId, groupProfile, membership} GroupMember {groupMemberId, memberId, memberRole = memRole} cReq = do
|
||||
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
|
||||
msg <- sendDirectContactMessage ct $ XGrpInv groupInv
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg content Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
setActive $ ActiveG localDisplayName
|
||||
|
||||
setExpireCIs :: (MonadUnliftIO m, MonadReader ChatController m) => Bool -> m ()
|
||||
setExpireCIs b = do
|
||||
@@ -1266,15 +1297,19 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F
|
||||
f = filePath `combine` (name <> suffix <> ext)
|
||||
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
|
||||
|
||||
acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> m Contact
|
||||
acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} = do
|
||||
-- [incognito] generate profile to send, create connection with incognito profile
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe Profile -> m Contact
|
||||
acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} incognitoProfile = do
|
||||
let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile
|
||||
-- TODO acceptContactAsync
|
||||
connId <- withAgent $ \a -> acceptContact a True invId . directMessage $ XInfo profileToSend
|
||||
withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId incognitoProfile
|
||||
|
||||
deleteGroupLink' :: ChatMonad m => User -> GroupInfo -> m ()
|
||||
deleteGroupLink' user gInfo = do
|
||||
conn <- withStore $ \db -> getGroupLinkConnection db user gInfo
|
||||
deleteAgentConnectionAsync user conn `catchError` \_ -> pure ()
|
||||
withStore' $ \db -> deleteGroupLink db user gInfo
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
q <- asks $ subQ . smpAgent
|
||||
@@ -1340,10 +1375,7 @@ subscribeUserConnections agentBatchSubscribe user = do
|
||||
contactSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId Contact -> m ()
|
||||
contactSubsToView rs = toView . CRContactSubSummary . map (uncurry ContactSubStatus) . resultsFor rs
|
||||
contactLinkSubsToView :: Map ConnId (Either AgentErrorType ()) -> Map ConnId UserContact -> m ()
|
||||
contactLinkSubsToView rs ucs = case resultsFor rs ucs of
|
||||
[] -> pure ()
|
||||
((_, Just e) : _) -> toView $ CRUserContactLinkSubError e
|
||||
_ -> toView CRUserContactLinkSubscribed
|
||||
contactLinkSubsToView rs = toView . CRUserContactSubSummary . map (uncurry UserContactSubStatus) . resultsFor rs
|
||||
groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m ()
|
||||
groupSubsToView rs gs ms ce = do
|
||||
mapM_ groupSub $
|
||||
@@ -1581,12 +1613,21 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
|
||||
toView $ CRContactConnected ct (fmap fromLocalProfile incognitoProfile)
|
||||
setActive $ ActiveC c
|
||||
showToast (c <> "> ") "connected"
|
||||
forM_ viaUserContactLink $ \userContactLinkId -> do
|
||||
forM_ viaUserContactLink $ \userContactLinkId ->
|
||||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
Just (_, True, Just mc) -> do
|
||||
msg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
Just (_, True, mc_, groupId_) -> do
|
||||
forM_ mc_ $ \mc -> do
|
||||
msg <- sendDirectContactMessage ct (XMsgNew $ MCSimple (ExtMsgContent mc Nothing))
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
forM_ groupId_ $ \groupId -> do
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
gVar <- asks idsDrg
|
||||
-- TODO async and continuation?
|
||||
(grpAgentConnId, cReq) <- withAgent $ \a -> createConnection a True SCMInvitation
|
||||
member <- withStore $ \db -> createNewContactMember db gVar user groupId ct GRMember grpAgentConnId cReq
|
||||
sendGrpInvitation user ct gInfo member cReq
|
||||
toView $ CRSentGroupInvitation gInfo ct member
|
||||
_ -> pure ()
|
||||
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) -> do
|
||||
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
||||
@@ -1864,12 +1905,26 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
|
||||
withStore (\db -> createOrUpdateContactRequest db userId userContactLinkId invId p xContactId_) >>= \case
|
||||
CORContact contact -> toView $ CRContactRequestAlreadyAccepted contact
|
||||
CORRequest cReq@UserContactRequest {localDisplayName} -> do
|
||||
(_, autoAccept, _) <- withStore $ \db -> getUserContactLink db userId
|
||||
if autoAccept
|
||||
then acceptContactRequest user cReq >>= toView . CRAcceptingContactRequest
|
||||
else do
|
||||
toView $ CRReceivedContactRequest cReq
|
||||
showToast (localDisplayName <> "> ") "wants to connect to you"
|
||||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
Just (_, autoAccept, _, groupId_) ->
|
||||
if autoAccept
|
||||
then case groupId_ of
|
||||
Nothing -> do
|
||||
-- [incognito] generate profile to send, create connection with incognito profile
|
||||
-- TODO allow to configure incognito setting on auto accept instead of checking incognito mode
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
ct <- acceptContactRequest user cReq incognitoProfile
|
||||
toView $ CRAcceptingContactRequest ct
|
||||
Just groupId -> do
|
||||
gInfo@GroupInfo {membership} <- withStore $ \db -> getGroupInfo db user groupId
|
||||
let incognitoProfile = if memberIncognito membership then Just . fromLocalProfile $ memberProfile membership else Nothing
|
||||
ct <- acceptContactRequest user cReq incognitoProfile
|
||||
toView $ CRAcceptingGroupJoinRequest gInfo ct
|
||||
else do
|
||||
toView $ CRReceivedContactRequest cReq
|
||||
showToast (localDisplayName <> "> ") "wants to connect to you"
|
||||
_ -> pure ()
|
||||
|
||||
withCompletedCommand :: Connection -> ACommand 'Agent -> (CommandData -> m ()) -> m ()
|
||||
withCompletedCommand Connection {connId} agentMsg action = do
|
||||
@@ -2406,6 +2461,7 @@ processAgentMessage (Just user@User {userId, profile}) corrId agentConnId agentM
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
if memberId (membership :: GroupMember) == memId
|
||||
then checkRole membership $ do
|
||||
deleteGroupLink' user gInfo `catchError` \_ -> pure ()
|
||||
forM_ members $ deleteMemberConnection user
|
||||
deleteMember membership RGEUserDeleted
|
||||
toView $ CRDeletedMemberUser gInfo {membership = membership {memberStatus = GSMemRemoved}} m
|
||||
@@ -2914,6 +2970,12 @@ chatCommandP =
|
||||
("/groups" <|> "/gs") $> ListGroups,
|
||||
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
|
||||
("/group_profile #" <|> "/gp #" <|> "/group_profile " <|> "/gp ") *> (UpdateGroupProfile <$> displayName <* A.space <*> groupProfile),
|
||||
"/_create link #" *> (APICreateGroupLink <$> A.decimal),
|
||||
"/_delete link #" *> (APIDeleteGroupLink <$> A.decimal),
|
||||
"/_get link #" *> (APIGetGroupLink <$> A.decimal),
|
||||
"/create link #" *> (CreateGroupLink <$> displayName),
|
||||
"/delete link #" *> (DeleteGroupLink <$> displayName),
|
||||
"/show link #" *> (ShowGroupLink <$> displayName),
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> A.takeByteString),
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* optional (A.char '@') <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> A.takeByteString),
|
||||
("/contacts" <|> "/cs") $> ListContacts,
|
||||
|
||||
@@ -161,6 +161,9 @@ data ChatCommand
|
||||
| APILeaveGroup GroupId
|
||||
| APIListMembers GroupId
|
||||
| APIUpdateGroupProfile GroupId GroupProfile
|
||||
| APICreateGroupLink GroupId
|
||||
| APIDeleteGroupLink GroupId
|
||||
| APIGetGroupLink GroupId
|
||||
| GetUserSMPServers
|
||||
| SetUserSMPServers [SMPServer]
|
||||
| APISetChatItemTTL (Maybe Int64)
|
||||
@@ -203,6 +206,9 @@ data ChatCommand
|
||||
| ListMembers GroupName
|
||||
| ListGroups
|
||||
| UpdateGroupProfile GroupName GroupProfile
|
||||
| CreateGroupLink GroupName
|
||||
| DeleteGroupLink GroupName
|
||||
| ShowGroupLink GroupName
|
||||
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: ByteString, message :: ByteString}
|
||||
| LastMessages (Maybe ChatName) Int
|
||||
| SendFile ChatName FilePath
|
||||
@@ -295,6 +301,7 @@ data ChatResponse
|
||||
| CRContactsSubscribed {server :: SMPServer, contactRefs :: [ContactRef]}
|
||||
| CRContactSubError {contact :: Contact, chatError :: ChatError}
|
||||
| CRContactSubSummary {contactSubscriptions :: [ContactSubStatus]}
|
||||
| CRUserContactSubSummary {userContactSubscriptions :: [UserContactSubStatus]}
|
||||
| CRHostConnected {protocol :: AProtocolType, transportHost :: TransportHost}
|
||||
| CRHostDisconnected {protocol :: AProtocolType, transportHost :: TransportHost}
|
||||
| CRGroupInvitation {groupInfo :: GroupInfo}
|
||||
@@ -312,6 +319,10 @@ data ChatResponse
|
||||
| CRGroupRemoved {groupInfo :: GroupInfo}
|
||||
| CRGroupDeleted {groupInfo :: GroupInfo, member :: GroupMember}
|
||||
| CRGroupUpdated {fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
|
||||
| CRGroupLinkCreated {groupInfo :: GroupInfo, connReqContact :: ConnReqContact}
|
||||
| CRGroupLink {groupInfo :: GroupInfo, connReqContact :: ConnReqContact}
|
||||
| CRGroupLinkDeleted {groupInfo :: GroupInfo}
|
||||
| CRAcceptingGroupJoinRequest {groupInfo :: GroupInfo, contact :: Contact}
|
||||
| CRMemberSubError {groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError}
|
||||
| CRMemberSubSummary {memberSubscriptions :: [MemberSubStatus]}
|
||||
| CRGroupSubscribed {groupInfo :: GroupInfo}
|
||||
@@ -379,6 +390,16 @@ instance ToJSON MemberSubStatus where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
data UserContactSubStatus = UserContactSubStatus
|
||||
{ userContact :: UserContact,
|
||||
userContactError :: Maybe ChatError
|
||||
}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON UserContactSubStatus where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
data PendingSubStatus = PendingSubStatus
|
||||
{ connection :: PendingContactConnection,
|
||||
connError :: Maybe ChatError
|
||||
|
||||
@@ -0,0 +1,14 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20221011_user_contact_links_group_id where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20221011_user_contact_links_group_id :: Query
|
||||
m20221011_user_contact_links_group_id =
|
||||
[sql|
|
||||
ALTER TABLE user_contact_links ADD COLUMN group_id INTEGER REFERENCES groups ON DELETE CASCADE;
|
||||
|
||||
CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(group_id);
|
||||
|]
|
||||
@@ -259,6 +259,7 @@ CREATE TABLE user_contact_links(
|
||||
updated_at TEXT CHECK(updated_at NOT NULL),
|
||||
auto_accept INTEGER DEFAULT 0,
|
||||
auto_reply_msg_content TEXT DEFAULT NULL,
|
||||
group_id INTEGER REFERENCES groups ON DELETE CASCADE,
|
||||
UNIQUE(user_id, local_display_name)
|
||||
);
|
||||
CREATE TABLE contact_requests(
|
||||
@@ -427,3 +428,6 @@ CREATE UNIQUE INDEX idx_chat_items_group_shared_msg_id ON chat_items(
|
||||
shared_msg_id
|
||||
);
|
||||
CREATE INDEX idx_msg_deliveries_message_id ON msg_deliveries(message_id);
|
||||
CREATE UNIQUE INDEX idx_user_contact_links_group_id ON user_contact_links(
|
||||
group_id
|
||||
);
|
||||
|
||||
+134
-47
@@ -43,12 +43,16 @@ module Simplex.Chat.Store
|
||||
updateContactConnectionAlias,
|
||||
getUserContacts,
|
||||
createUserContactLink,
|
||||
getUserContactLinkConnections,
|
||||
getUserAddressConnections,
|
||||
getUserContactLinks,
|
||||
deleteUserContactLink,
|
||||
getUserContactLink,
|
||||
deleteUserAddress,
|
||||
getUserAddress,
|
||||
getUserContactLinkById,
|
||||
updateUserContactLinkAutoAccept,
|
||||
updateUserAddressAutoAccept,
|
||||
createGroupLink,
|
||||
getGroupLinkConnection,
|
||||
deleteGroupLink,
|
||||
getGroupLink,
|
||||
createOrUpdateContactRequest,
|
||||
getContactRequest,
|
||||
getContactRequestIdByName,
|
||||
@@ -265,6 +269,7 @@ import Simplex.Chat.Migrations.M20220928_settings
|
||||
import Simplex.Chat.Migrations.M20221001_shared_msg_id_indices
|
||||
import Simplex.Chat.Migrations.M20221003_delete_broken_integrity_error_chat_items
|
||||
import Simplex.Chat.Migrations.M20221004_idx_msg_deliveries_message_id
|
||||
import Simplex.Chat.Migrations.M20221011_user_contact_links_group_id
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..))
|
||||
@@ -304,7 +309,8 @@ schemaMigrations =
|
||||
("20220928_settings", m20220928_settings),
|
||||
("20221001_shared_msg_id_indices", m20221001_shared_msg_id_indices),
|
||||
("20221003_delete_broken_integrity_error_chat_items", m20221003_delete_broken_integrity_error_chat_items),
|
||||
("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id)
|
||||
("20221004_idx_msg_deliveries_message_id", m20221004_idx_msg_deliveries_message_id),
|
||||
("20221011_user_contact_links_group_id", m20221011_user_contact_links_group_id)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
@@ -683,33 +689,45 @@ createUserContactLink db userId agentConnId cReq =
|
||||
userContactLinkId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnUserContact (Just userContactLinkId) agentConnId Nothing Nothing Nothing 0 currentTs
|
||||
|
||||
getUserContactLinkConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection]
|
||||
getUserContactLinkConnections db user = do
|
||||
cs <- liftIO $ getUserContactLinks db user
|
||||
if null cs then throwError SEUserContactLinkNotFound else pure $ map fst cs
|
||||
getUserAddressConnections :: DB.Connection -> User -> ExceptT StoreError IO [Connection]
|
||||
getUserAddressConnections db User {userId} = do
|
||||
cs <- liftIO getUserAddressConnections_
|
||||
if null cs then throwError SEUserContactLinkNotFound else pure cs
|
||||
where
|
||||
getUserAddressConnections_ :: IO [Connection]
|
||||
getUserAddressConnections_ =
|
||||
map toConnection
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id,
|
||||
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
||||
WHERE c.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|
||||
|]
|
||||
(userId, userId)
|
||||
|
||||
getUserContactLinks :: DB.Connection -> User -> IO [(Connection, UserContact)]
|
||||
getUserContactLinks db User {userId} =
|
||||
map toResult
|
||||
<$> DB.queryNamed
|
||||
map toUserContactConnection
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id,
|
||||
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at,
|
||||
uc.user_contact_link_id, uc.conn_req_contact
|
||||
uc.user_contact_link_id, uc.conn_req_contact, uc.group_id
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
||||
WHERE c.user_id = :user_id
|
||||
AND uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
WHERE c.user_id = ? AND uc.user_id = ?
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
(userId, userId)
|
||||
where
|
||||
toResult :: (ConnectionRow :. (Int64, ConnReqContact)) -> (Connection, UserContact)
|
||||
toResult (connRow :. (userContactLinkId, connReqContact)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact})
|
||||
toUserContactConnection :: (ConnectionRow :. (Int64, ConnReqContact, Maybe GroupId)) -> (Connection, UserContact)
|
||||
toUserContactConnection (connRow :. (userContactLinkId, connReqContact, groupId)) = (toConnection connRow, UserContact {userContactLinkId, connReqContact, groupId})
|
||||
|
||||
deleteUserContactLink :: DB.Connection -> User -> IO ()
|
||||
deleteUserContactLink db User {userId} = do
|
||||
deleteUserAddress :: DB.Connection -> User -> IO ()
|
||||
deleteUserAddress db User {userId} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
@@ -717,7 +735,7 @@ deleteUserContactLink db User {userId} = do
|
||||
SELECT connection_id
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = ? AND uc.local_display_name = ''
|
||||
WHERE uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|
||||
)
|
||||
|]
|
||||
(Only userId)
|
||||
@@ -730,8 +748,7 @@ deleteUserContactLink db User {userId} = do
|
||||
SELECT cr.local_display_name
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
@@ -743,57 +760,124 @@ deleteUserContactLink db User {userId} = do
|
||||
SELECT cr.contact_profile_id
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = :user_id
|
||||
AND uc.local_display_name = ''
|
||||
WHERE uc.user_id = :user_id AND uc.local_display_name = '' AND uc.group_id IS NULL
|
||||
)
|
||||
|]
|
||||
[":user_id" := userId]
|
||||
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = ''" (Only userId)
|
||||
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL" (Only userId)
|
||||
|
||||
getUserContactLink :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
|
||||
getUserContactLink db userId =
|
||||
getUserAddress :: DB.Connection -> UserId -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
|
||||
getUserAddress db userId =
|
||||
ExceptT . firstRow id SEUserContactLinkNotFound $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, auto_reply_msg_content
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
AND local_display_name = ''
|
||||
WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
|
||||
|]
|
||||
(Only userId)
|
||||
|
||||
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (ConnReqContact, Bool, Maybe MsgContent))
|
||||
getUserContactLinkById :: DB.Connection -> UserId -> Int64 -> IO (Maybe (ConnReqContact, Bool, Maybe MsgContent, Maybe GroupId))
|
||||
getUserContactLinkById db userId userContactLinkId =
|
||||
maybeFirstRow id $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, auto_reply_msg_content
|
||||
SELECT conn_req_contact, auto_accept, auto_reply_msg_content, group_id
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ?
|
||||
AND user_contact_link_id = ?
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
|
||||
updateUserContactLinkAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
|
||||
updateUserContactLinkAutoAccept db userId autoAccept msgContent = do
|
||||
(cReqUri, _, _) <- getUserContactLink db userId
|
||||
liftIO updateUserContactLinkAutoAccept_
|
||||
updateUserAddressAutoAccept :: DB.Connection -> UserId -> Bool -> Maybe MsgContent -> ExceptT StoreError IO (ConnReqContact, Bool, Maybe MsgContent)
|
||||
updateUserAddressAutoAccept db userId autoAccept msgContent = do
|
||||
(cReqUri, _, _) <- getUserAddress db userId
|
||||
liftIO updateUserAddressAutoAccept_
|
||||
pure (cReqUri, autoAccept, msgContent)
|
||||
where
|
||||
updateUserContactLinkAutoAccept_ :: IO ()
|
||||
updateUserContactLinkAutoAccept_ =
|
||||
updateUserAddressAutoAccept_ :: IO ()
|
||||
updateUserAddressAutoAccept_ =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE user_contact_links
|
||||
SET auto_accept = ?, auto_reply_msg_content = ?
|
||||
WHERE user_id = ?
|
||||
AND local_display_name = ''
|
||||
WHERE user_id = ? AND local_display_name = '' AND group_id IS NULL
|
||||
|]
|
||||
(autoAccept, msgContent, userId)
|
||||
|
||||
createGroupLink :: DB.Connection -> User -> GroupInfo -> ConnId -> ConnReqContact -> ExceptT StoreError IO ()
|
||||
createGroupLink db User {userId} groupInfo@GroupInfo {groupId, localDisplayName} agentConnId cReq =
|
||||
checkConstraint (SEDuplicateGroupLink groupInfo) . liftIO $ do
|
||||
currentTs <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"INSERT INTO user_contact_links (user_id, group_id, local_display_name, conn_req_contact, auto_accept, created_at, updated_at) VALUES (?,?,?,?,?,?,?)"
|
||||
(userId, groupId, "group_link_" <> localDisplayName, cReq, True, currentTs, currentTs)
|
||||
groupLinkId <- insertedRowId db
|
||||
void $ createConnection_ db userId ConnUserContact (Just groupLinkId) agentConnId Nothing Nothing Nothing 0 currentTs
|
||||
|
||||
getGroupLinkConnection :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO Connection
|
||||
getGroupLinkConnection db User {userId} groupInfo@GroupInfo {groupId} =
|
||||
ExceptT . firstRow toConnection (SEGroupLinkNotFound groupInfo) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.custom_user_profile_id,
|
||||
c.conn_status, c.conn_type, c.local_alias, c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc ON c.user_contact_link_id = uc.user_contact_link_id
|
||||
WHERE c.user_id = ? AND uc.user_id = ? AND uc.group_id = ?
|
||||
|]
|
||||
(userId, userId, groupId)
|
||||
|
||||
deleteGroupLink :: DB.Connection -> User -> GroupInfo -> IO ()
|
||||
deleteGroupLink db User {userId} GroupInfo {groupId} = do
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM connections WHERE connection_id IN (
|
||||
SELECT connection_id
|
||||
FROM connections c
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = ? AND uc.group_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, groupId)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM display_names
|
||||
WHERE user_id = ?
|
||||
AND local_display_name in (
|
||||
SELECT cr.local_display_name
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = ? AND uc.group_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, userId, groupId)
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
DELETE FROM contact_profiles
|
||||
WHERE contact_profile_id in (
|
||||
SELECT cr.contact_profile_id
|
||||
FROM contact_requests cr
|
||||
JOIN user_contact_links uc USING (user_contact_link_id)
|
||||
WHERE uc.user_id = ? AND uc.group_id = ?
|
||||
)
|
||||
|]
|
||||
(userId, groupId)
|
||||
DB.execute db "DELETE FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId)
|
||||
|
||||
getGroupLink :: DB.Connection -> User -> GroupInfo -> ExceptT StoreError IO ConnReqContact
|
||||
getGroupLink db User {userId} gInfo@GroupInfo {groupId} =
|
||||
ExceptT . firstRow fromOnly (SEGroupLinkNotFound gInfo) $
|
||||
DB.query db "SELECT conn_req_contact FROM user_contact_links WHERE user_id = ? AND group_id = ?" (userId, groupId)
|
||||
|
||||
createOrUpdateContactRequest :: DB.Connection -> UserId -> Int64 -> InvitationId -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
|
||||
createOrUpdateContactRequest db userId userContactLinkId invId Profile {displayName, fullName, image} xContactId_ =
|
||||
liftIO (maybeM getContact' xContactId_) >>= \case
|
||||
@@ -1307,14 +1391,14 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
<$> DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact
|
||||
SELECT conn_req_contact, group_id
|
||||
FROM user_contact_links
|
||||
WHERE user_id = ? AND user_contact_link_id = ?
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
where
|
||||
userContact_ :: [Only ConnReqContact] -> Either StoreError UserContact
|
||||
userContact_ [Only cReq] = Right UserContact {userContactLinkId, connReqContact = cReq}
|
||||
userContact_ :: [(ConnReqContact, Maybe GroupId)] -> Either StoreError UserContact
|
||||
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
getConnectionById :: DB.Connection -> User -> Int64 -> ExceptT StoreError IO Connection
|
||||
@@ -2947,11 +3031,12 @@ getContactRequestChatPreviews_ db User {userId} =
|
||||
cr.contact_request_id, cr.local_display_name, cr.agent_invitation_id, cr.user_contact_link_id,
|
||||
c.agent_conn_id, cr.contact_profile_id, p.display_name, p.full_name, p.image, cr.xcontact_id, cr.created_at, cr.updated_at
|
||||
FROM contact_requests cr
|
||||
JOIN connections c USING (user_contact_link_id)
|
||||
JOIN contact_profiles p USING (contact_profile_id)
|
||||
WHERE cr.user_id = ?
|
||||
JOIN connections c ON c.user_contact_link_id = cr.user_contact_link_id
|
||||
JOIN contact_profiles p ON p.contact_profile_id = cr.contact_profile_id
|
||||
JOIN user_contact_links uc ON uc.user_contact_link_id = cr.user_contact_link_id
|
||||
WHERE cr.user_id = ? AND uc.user_id = ? AND uc.local_display_name = '' AND uc.group_id IS NULL
|
||||
|]
|
||||
(Only userId)
|
||||
(userId, userId)
|
||||
where
|
||||
toContactRequestChatPreview :: ContactRequestRow -> AChat
|
||||
toContactRequestChatPreview cReqRow =
|
||||
@@ -4240,6 +4325,8 @@ data StoreError
|
||||
| SEChatItemNotFoundByFileId {fileId :: FileTransferId}
|
||||
| SEChatItemNotFoundByGroupId {groupId :: GroupId}
|
||||
| SEProfileNotFound {profileId :: Int64}
|
||||
| SEDuplicateGroupLink {groupInfo :: GroupInfo}
|
||||
| SEGroupLinkNotFound {groupInfo :: GroupInfo}
|
||||
deriving (Show, Exception, Generic)
|
||||
|
||||
instance ToJSON StoreError where
|
||||
|
||||
@@ -110,10 +110,14 @@ instance ToJSON ContactRef where toEncoding = J.genericToEncoding J.defaultOptio
|
||||
|
||||
data UserContact = UserContact
|
||||
{ userContactLinkId :: Int64,
|
||||
connReqContact :: ConnReqContact
|
||||
connReqContact :: ConnReqContact,
|
||||
groupId :: Maybe GroupId
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
userContactGroupId :: UserContact -> Maybe GroupId
|
||||
userContactGroupId UserContact {groupId} = groupId
|
||||
|
||||
instance ToJSON UserContact where
|
||||
toJSON = J.genericToJSON J.defaultOptions
|
||||
toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
@@ -141,6 +141,13 @@ responseToView testView = \case
|
||||
[sShow (length subscribed) <> " contacts connected (use " <> highlight' "/cs" <> " for the list)" | not (null subscribed)] <> viewErrorsSummary errors " contact errors"
|
||||
where
|
||||
(errors, subscribed) = partition (isJust . contactError) summary
|
||||
CRUserContactSubSummary summary ->
|
||||
map addressSS addresses
|
||||
<> ([sShow (length groupLinksSubscribed) <> " group links active" | not (null groupLinksSubscribed)] <> viewErrorsSummary groupLinkErrors " group link errors")
|
||||
where
|
||||
(addresses, groupLinks) = partition (\UserContactSubStatus {userContact} -> isNothing . userContactGroupId $ userContact) summary
|
||||
addressSS UserContactSubStatus {userContactError} = maybe ("Your address is active! To show: " <> highlight' "/sa") (\e -> "User address error: " <> sShow e <> ", to delete your address: " <> highlight' "/da") userContactError
|
||||
(groupLinkErrors, groupLinksSubscribed) = partition (isJust . userContactError) groupLinks
|
||||
CRGroupInvitation g -> [groupInvitation' g]
|
||||
CRReceivedGroupInvitation g c role -> viewReceivedGroupInvitation g c role
|
||||
CRUserJoinedGroup g _ -> viewUserJoinedGroup g
|
||||
@@ -158,6 +165,10 @@ responseToView testView = \case
|
||||
CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"]
|
||||
CRGroupDeleted g m -> [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"]
|
||||
CRGroupUpdated g g' m -> viewGroupUpdated g g' m
|
||||
CRGroupLinkCreated g cReq -> groupLink_ "Group link is created!" g cReq
|
||||
CRGroupLink g cReq -> groupLink_ "Group link:" g cReq
|
||||
CRGroupLinkDeleted g -> viewGroupLinkDeleted g
|
||||
CRAcceptingGroupJoinRequest g c -> [ttyFullContact c <> ": accepting request to join group " <> ttyGroup' g <> "..."]
|
||||
CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e]
|
||||
CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors"
|
||||
CRGroupSubscribed g -> viewGroupSubscribed g
|
||||
@@ -424,6 +435,23 @@ autoAcceptStatus_ autoAccept autoReply =
|
||||
("auto_accept " <> if autoAccept then "on" else "off") :
|
||||
maybe [] ((["auto reply:"] <>) . ttyMsgContent) autoReply
|
||||
|
||||
groupLink_ :: StyledString -> GroupInfo -> ConnReqContact -> [StyledString]
|
||||
groupLink_ intro g cReq =
|
||||
[ intro,
|
||||
"",
|
||||
(plain . strEncode) cReq,
|
||||
"",
|
||||
"Anybody can connect to you and join group with: " <> highlight' "/c <group_link_above>",
|
||||
"to show it again: " <> highlight ("/show link #" <> groupName' g),
|
||||
"to delete it: " <> highlight ("/delete link #" <> groupName' g) <> " (joined members will remain connected to you)"
|
||||
]
|
||||
|
||||
viewGroupLinkDeleted :: GroupInfo -> [StyledString]
|
||||
viewGroupLinkDeleted g =
|
||||
[ "Group link is deleted - joined members will remain connected.",
|
||||
"To create a new group link use " <> highlight ("/create link #" <> groupName' g)
|
||||
]
|
||||
|
||||
viewSentInvitation :: Maybe Profile -> Bool -> [StyledString]
|
||||
viewSentInvitation incognitoProfile testView =
|
||||
case incognitoProfile of
|
||||
@@ -988,6 +1016,8 @@ viewChatError = \case
|
||||
SEFileIdNotFoundBySharedMsgId _ -> [] -- recipient tried to accept cancelled file
|
||||
SEConnectionNotFound _ -> [] -- TODO mutes delete group error, but also mutes any error from getConnectionEntity
|
||||
SEQuotedChatItemNotFound -> ["message not found - reply is not sent"]
|
||||
SEDuplicateGroupLink g -> ["you already have link for this group, to show: " <> highlight ("/show link #" <> groupName' g)]
|
||||
SEGroupLinkNotFound g -> ["no group link, to create: " <> highlight ("/create link #" <> groupName' g)]
|
||||
e -> ["chat db error: " <> sShow e]
|
||||
ChatErrorDatabase err -> case err of
|
||||
DBErrorEncrypted -> ["error: chat database is already encrypted"]
|
||||
|
||||
Reference in New Issue
Block a user