IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: contacts without connections (#3313)

Browse Source 
* core: contacts without connections

* compiles (some tests don't pass)

* remove commented code

* filter out user contact (fixes tests)

---------

Co-authored-by: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2023-11-03 18:15:07 +00:00 committed by GitHub
parent 3d7258fa58
commit 4816150b99
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 217 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
apps/simplex-broadcast-bot/src/Broadcast/Bot.hs
View File

@ -62,7 +62,8 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u
MCLink {} -> True MCLink {} -> True
MCImage {} -> True MCImage {} -> True
_ -> False _ -> False
broadcastTo ct'@Contact {activeConn = conn@Connection {connStatus}} = broadcastTo Contact {activeConn = Nothing} = False
broadcastTo ct'@Contact {activeConn = Just conn@Connection {connStatus}} =
(connStatus == ConnSndReady || connStatus == ConnReady) (connStatus == ConnSndReady || connStatus == ConnReady)
&& not (connDisabled conn) && not (connDisabled conn)
&& contactId' ct' /= contactId' ct && contactId' ct' /= contactId' ct

214
src/Simplex/Chat.hs
View File

@ -614,8 +614,8 @@ processChatCommand = \case
let fileName = takeFileName file let fileName = takeFileName file
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing} fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
chSize <- asks $ fileChunkSize . config chSize <- asks $ fileChunkSize . config
withStore' $ \db -> do withStore $ \db -> do
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize subMode ft@FileTransferMeta {fileId} <- liftIO $ createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize subMode
fileStatus <- case fileInline of fileStatus <- case fileInline of
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1 Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
_ -> pure CIFSSndStored _ -> pure CIFSSndStored
@ -749,7 +749,8 @@ processChatCommand = \case
let fileSource = Just $ CryptoFile filePath cfArgs let fileSource = Just $ CryptoFile filePath cfArgs
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
case contactOrGroup of case contactOrGroup of
CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr CGContact Contact {activeConn} -> forM_ activeConn $ \conn ->
withStore' $ \db -> createSndFTDescrXFTP db user Nothing conn ft fileDescr
CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user))
where where
-- we are not sending files to pending members, same as with inline files -- we are not sending files to pending members, same as with inline files
@ -1190,7 +1191,8 @@ processChatCommand = \case
ct <- getContact db user chatId ct <- getContact db user chatId
liftIO $ updateContactSettings db user chatId chatSettings liftIO $ updateContactSettings db user chatId chatSettings
pure ct pure ct
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings) forM_ (contactConnId ct) $ \connId ->
withAgent $ \a -> toggleConnectionNtfs a connId (chatHasNtfs chatSettings)
ok user ok user
CTGroup -> do CTGroup -> do
ms <- withStore $ \db -> do ms <- withStore $ \db -> do
@ -1211,9 +1213,12 @@ processChatCommand = \case
ok user ok user
APIContactInfo contactId -> withUser $ \user@User {userId} -> do APIContactInfo contactId -> withUser $ \user@User {userId} -> do
-- [incognito] print user's incognito profile for this contact -- [incognito] print user's incognito profile for this contact
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) incognitoProfile <- case activeConn of
connectionStats <- withAgent (`getConnectionServers` contactConnId ct) Nothing -> pure Nothing
Just Connection {customUserProfileId} ->
forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
connectionStats <- mapM (withAgent . flip getConnectionServers) (contactConnId ct)
pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile) pure $ CRContactInfo user ct connectionStats (fmap fromLocalProfile incognitoProfile)
APIGroupInfo gId -> withUser $ \user -> do APIGroupInfo gId -> withUser $ \user -> do
(g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId) (g, s) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> liftIO (getGroupSummary db user gId)
@ -1224,8 +1229,11 @@ processChatCommand = \case
pure $ CRGroupMemberInfo user g m connectionStats pure $ CRGroupMemberInfo user g m connectionStats
APISwitchContact contactId -> withUser $ \user -> do APISwitchContact contactId -> withUser $ \user -> do
ct <- withStore $ \db -> getContact db user contactId ct <- withStore $ \db -> getContact db user contactId
connectionStats <- withAgent $ \a -> switchConnectionAsync a "" $ contactConnId ct case contactConnId ct of
pure $ CRContactSwitchStarted user ct connectionStats Just connId -> do
connectionStats <- withAgent $ \a -> switchConnectionAsync a "" connId
pure $ CRContactSwitchStarted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of case memberConnId m of
@ -1235,8 +1243,11 @@ processChatCommand = \case
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APIAbortSwitchContact contactId -> withUser $ \user -> do APIAbortSwitchContact contactId -> withUser $ \user -> do
ct <- withStore $ \db -> getContact db user contactId ct <- withStore $ \db -> getContact db user contactId
connectionStats <- withAgent $ \a -> abortConnectionSwitch a $ contactConnId ct case contactConnId ct of
pure $ CRContactSwitchAborted user ct connectionStats Just connId -> do
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
pure $ CRContactSwitchAborted user ct connectionStats
Nothing -> throwChatError $ CEContactNotActive ct
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of case memberConnId m of
@ -1246,9 +1257,12 @@ processChatCommand = \case
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APISyncContactRatchet contactId force -> withUser $ \user -> do APISyncContactRatchet contactId force -> withUser $ \user -> do
ct <- withStore $ \db -> getContact db user contactId ct <- withStore $ \db -> getContact db user contactId
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (contactConnId ct) force case contactConnId ct of
createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing Just connId -> do
pure $ CRContactRatchetSyncStarted user ct cStats cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force
createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing
pure $ CRContactRatchetSyncStarted user ct cStats
Nothing -> throwChatError $ CEContactNotActive ct
APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> do APISyncGroupMemberRatchet gId gMemberId force -> withUser $ \user -> do
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId (g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
case memberConnId m of case memberConnId m of
@ -1258,16 +1272,19 @@ processChatCommand = \case
pure $ CRGroupMemberRatchetSyncStarted user g m cStats pure $ CRGroupMemberRatchetSyncStarted user g m cStats
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APIGetContactCode contactId -> withUser $ \user -> do APIGetContactCode contactId -> withUser $ \user -> do
ct@Contact {activeConn = conn@Connection {connId}} <- withStore $ \db -> getContact db user contactId ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
code <- getConnectionCode (contactConnId ct) case activeConn of
ct' <- case contactSecurityCode ct of Just conn@Connection {connId} -> do
Just SecurityCode {securityCode} code <- getConnectionCode $ aConnId conn
| sameVerificationCode code securityCode -> pure ct ct' <- case contactSecurityCode ct of
| otherwise -> do Just SecurityCode {securityCode}
withStore' $ \db -> setConnectionVerified db user connId Nothing | sameVerificationCode code securityCode -> pure ct
pure (ct :: Contact) {activeConn = conn {connectionCode = Nothing}} | otherwise -> do
_ -> pure ct withStore' $ \db -> setConnectionVerified db user connId Nothing
pure $ CRContactCode user ct' code pure (ct :: Contact) {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}}
_ -> pure ct
pure $ CRContactCode user ct' code
Nothing -> throwChatError $ CEContactNotActive ct
APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do APIGetGroupMemberCode gId gMemberId -> withUser $ \user -> do
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId (g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
case activeConn of case activeConn of
@ -1283,17 +1300,22 @@ processChatCommand = \case
pure $ CRGroupMemberCode user g m' code pure $ CRGroupMemberCode user g m' code
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APIVerifyContact contactId code -> withUser $ \user -> do APIVerifyContact contactId code -> withUser $ \user -> do
Contact {activeConn} <- withStore $ \db -> getContact db user contactId ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
verifyConnectionCode user activeConn code case activeConn of
Just conn -> verifyConnectionCode user conn code
Nothing -> throwChatError $ CEContactNotActive ct
APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId
case activeConn of case activeConn of
Just conn -> verifyConnectionCode user conn code Just conn -> verifyConnectionCode user conn code
_ -> throwChatError CEGroupMemberNotActive _ -> throwChatError CEGroupMemberNotActive
APIEnableContact contactId -> withUser $ \user -> do APIEnableContact contactId -> withUser $ \user -> do
Contact {activeConn} <- withStore $ \db -> getContact db user contactId ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
withStore' $ \db -> setConnectionAuthErrCounter db user activeConn 0 case activeConn of
ok user Just conn -> do
withStore' $ \db -> setConnectionAuthErrCounter db user conn 0
ok user
Nothing -> throwChatError $ CEContactNotActive ct
APIEnableGroupMember gId gMemberId -> withUser $ \user -> do APIEnableGroupMember gId gMemberId -> withUser $ \user -> do
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId
case activeConn of case activeConn of
@ -1554,16 +1576,19 @@ processChatCommand = \case
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
(inv,) <$> getContactViaMember db user fromMember (inv,) <$> getContactViaMember db user fromMember
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
Contact {activeConn = Connection {peerChatVRange}} = ct Contact {activeConn} = ct
subMode <- chatReadVar subscriptionMode case activeConn of
dm <- directMessage $ XGrpAcpt membership.memberId Just Connection {peerChatVRange} -> do
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode subMode <- chatReadVar subscriptionMode
withStore' $ \db -> do dm <- directMessage $ XGrpAcpt membership.memberId
createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode
updateGroupMemberStatus db userId fromMember GSMemAccepted withStore' $ \db -> do
updateGroupMemberStatus db userId membership GSMemAccepted createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode
updateCIGroupInvitationStatus user updateGroupMemberStatus db userId fromMember GSMemAccepted
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing updateGroupMemberStatus db userId membership GSMemAccepted
updateCIGroupInvitationStatus user
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
Nothing -> throwChatError $ CEContactNotActive ct
where where
updateCIGroupInvitationStatus user = do updateCIGroupInvitationStatus user = do
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
@ -2064,7 +2089,8 @@ processChatCommand = \case
void $ sendDirectContactMessage ct' (XInfo mergedProfile') void $ sendDirectContactMessage ct' (XInfo mergedProfile')
when (directOrUsed ct') $ createSndFeatureItems user' ct ct' when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse updateContactPrefs :: User -> Contact -> Preferences -> m ChatResponse
updateContactPrefs user@User {userId} ct@Contact {activeConn = Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct
updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs'
| contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct | contactUserPrefs == contactUserPrefs' = pure $ CRContactPrefsUpdated user ct ct
| otherwise = do | otherwise = do
assertDirectAllowed user MDSnd ct XInfo_ assertDirectAllowed user MDSnd ct XInfo_
@ -2595,8 +2621,8 @@ acceptContactRequestAsync user UserContactRequest {agentInvitationId = AgentInvI
let profileToSend = profileToSendOnAccept user incognitoProfile let profileToSend = profileToSendOnAccept user incognitoProfile
(cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode (cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode
withStore' $ \db -> do withStore' $ \db -> do
ct@Contact {activeConn = Connection {connId}} <- createAcceptedContact db user acId (fromJVersionRange cReqChatVRange) cName profileId p userContactLinkId xContactId incognitoProfile subMode ct@Contact {activeConn} <- createAcceptedContact db user acId (fromJVersionRange cReqChatVRange) cName profileId p userContactLinkId xContactId incognitoProfile subMode
setCommandConnId db user cmdId connId forM_ activeConn $ \Connection {connId} -> setCommandConnId db user cmdId connId
pure ct pure ct
acceptGroupJoinRequestAsync :: ChatMonad m => User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> m GroupMember acceptGroupJoinRequestAsync :: ChatMonad m => User -> GroupInfo -> UserContactRequest -> GroupMemberRole -> Maybe IncognitoProfile -> m GroupMember
@ -2717,7 +2743,7 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
getContactConns :: m ([ConnId], Map ConnId Contact) getContactConns :: m ([ConnId], Map ConnId Contact)
getContactConns = do getContactConns = do
cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts cts <- withStore_ ("subscribeUserConnections " <> show userId <> ", getUserContacts") getUserContacts
let connIds = map contactConnId (filter contactActive cts) let connIds = catMaybes $ map contactConnId (filter contactActive cts)
pure (connIds, M.fromList $ zip connIds cts) pure (connIds, M.fromList $ zip connIds cts)
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact) getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
getUserContactLinkConns = do getUserContactLinkConns = do
@ -2758,9 +2784,10 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
toView $ CRNetworkStatuses (Just user) $ map (uncurry ConnNetworkStatus) statuses toView $ CRNetworkStatuses (Just user) $ map (uncurry ConnNetworkStatus) statuses
where where
addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)] addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)]
addStatus connId ct = addStatus _ Contact {activeConn = Nothing} nss = nss
let ns = (contactAgentConnId ct, netStatus $ resultErr connId rs) addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss =
in (ns :) let ns = (agentConnId, netStatus $ resultErr connId rs)
in ns : nss
netStatus :: Maybe ChatError -> NetworkStatus netStatus :: Maybe ChatError -> NetworkStatus
netStatus = maybe NSConnected $ NSError . errorNetworkStatus netStatus = maybe NSConnected $ NSError . errorNetworkStatus
errorNetworkStatus :: ChatError -> String errorNetworkStatus :: ChatError -> String
@ -3203,7 +3230,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
cmdId <- createAckCmd conn cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId msgMeta $ do withAckMessage agentConnId cmdId msgMeta $ do
(conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId (conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveRcvMSG conn (ConnectionId connId) msgMeta msgBody cmdId
let ct' = ct {activeConn = conn'} :: Contact let ct' = ct {activeConn = Just conn'} :: Contact
assertDirectAllowed user MDRcv ct' $ toCMEventTag event assertDirectAllowed user MDRcv ct' $ toCMEventTag event
updateChatLock "directMessage" event updateChatLock "directMessage" event
case event of case event of
@ -3311,7 +3338,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr (RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
(RSAgreed, Just _, _) -> do (RSAgreed, Just _, _) -> do
withStore' $ \db -> setConnectionVerified db user connId Nothing withStore' $ \db -> setConnectionVerified db user connId Nothing
let ct' = ct {activeConn = conn {connectionCode = Nothing}} :: Contact let ct' = ct {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} :: Contact
ratchetSyncEventItem ct' ratchetSyncEventItem ct'
securityCodeChanged ct' securityCodeChanged ct'
_ -> ratchetSyncEventItem ct _ -> ratchetSyncEventItem ct
@ -3464,11 +3491,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
notifyMemberConnected gInfo m Nothing notifyMemberConnected gInfo m Nothing
let connectedIncognito = memberIncognito membership let connectedIncognito = memberIncognito membership
when (memberCategory m == GCPreMember) $ probeMatchingMemberContact m connectedIncognito when (memberCategory m == GCPreMember) $ probeMatchingMemberContact m connectedIncognito
Just ct@Contact {activeConn = Connection {connStatus}} -> Just ct@Contact {activeConn} ->
when (connStatus == ConnReady) $ do forM_ activeConn $ \Connection {connStatus} ->
notifyMemberConnected gInfo m $ Just ct when (connStatus == ConnReady) $ do
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo notifyMemberConnected gInfo m $ Just ct
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
MSG msgMeta _msgFlags msgBody -> do MSG msgMeta _msgFlags msgBody -> do
cmdId <- createAckCmd conn cmdId <- createAckCmd conn
withAckMessage agentConnId cmdId msgMeta $ do withAckMessage agentConnId cmdId msgMeta $ do
@ -4279,7 +4307,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
_ -> do _ -> do
event <- withStore $ \db -> do event <- withStore $ \db -> do
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1 ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
sft <- liftIO $ createSndDirectInlineFT db ct ft sft <- createSndDirectInlineFT db ct ft
pure $ CRSndFileStart user ci' sft pure $ CRSndFileStart user ci' sft
toView event toView event
ifM ifM
@ -4395,30 +4423,31 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m () processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
processGroupInvitation ct inv msg msgMeta = do processGroupInvitation ct inv msg msgMeta = do
let Contact {localDisplayName = c, activeConn = Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct let Contact {localDisplayName = c, activeConn} = ct
GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta forM_ activeConn $ \Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c) checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId -- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
if sameGroupLinkId groupLinkId groupLinkId' (gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
then do if sameGroupLinkId groupLinkId groupLinkId'
subMode <- chatReadVar subscriptionMode then do
dm <- directMessage $ XGrpAcpt memberId subMode <- chatReadVar subscriptionMode
connIds <- joinAgentConnectionAsync user True connRequest dm subMode dm <- directMessage $ XGrpAcpt memberId
withStore' $ \db -> do connIds <- joinAgentConnectionAsync user True connRequest dm subMode
setViaGroupLinkHash db groupId connId withStore' $ \db -> do
createMemberConnectionAsync db user hostId connIds (fromJVersionRange peerChatVRange) subMode setViaGroupLinkHash db groupId connId
updateGroupMemberStatusById db userId hostId GSMemAccepted createMemberConnectionAsync db user hostId connIds (fromJVersionRange peerChatVRange) subMode
updateGroupMemberStatus db userId membership GSMemAccepted updateGroupMemberStatusById db userId hostId GSMemAccepted
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) updateGroupMemberStatus db userId membership GSMemAccepted
else do toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole else do
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole} toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
where where
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId (Just gli) (Just gli') = gli == gli' sameGroupLinkId (Just gli) (Just gli') = gli == gli'
@ -4441,7 +4470,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
contactConns <- withStore $ \db -> getContactConnections db userId ct' contactConns <- withStore $ \db -> getContactConnections db userId ct'
deleteAgentConnectionsAsync user $ map aConnId contactConns deleteAgentConnectionsAsync user $ map aConnId contactConns
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
let ct'' = ct' {activeConn = (contactConn ct') {connStatus = ConnDeleted}} :: Contact activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
let ct'' = ct' {activeConn = activeConn'} :: Contact
ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted) ci <- saveRcvChatItem user (CDDirectRcv ct'') msg msgMeta (CIRcvDirectEvent RDEContactDeleted)
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci) toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
toView $ CRContactDeletedByContact user ct'' toView $ CRContactDeletedByContact user ct''
@ -4951,20 +4981,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
Nothing -> createNewContact subMode Nothing -> createNewContact subMode
Just mContactId -> do Just mContactId -> do
mCt <- withStore $ \db -> getContact db user mContactId mCt <- withStore $ \db -> getContact db user mContactId
let Contact {activeConn = Connection {connId}, contactGrpInvSent} = mCt let Contact {activeConn, contactGrpInvSent} = mCt
if contactGrpInvSent forM_ activeConn $ \Connection {connId} ->
then do if contactGrpInvSent
ownConnReq <- withStore $ \db -> getConnReqInv db connId then do
-- in case both members sent x.grp.direct.inv before receiving other's for processing, ownConnReq <- withStore $ \db -> getConnReqInv db connId
-- only the one who received greater connReq joins, the other creates items and waits for confirmation -- in case both members sent x.grp.direct.inv before receiving other's for processing,
if strEncode connReq > strEncode ownConnReq -- only the one who received greater connReq joins, the other creates items and waits for confirmation
then joinExistingContact subMode mCt if strEncode connReq > strEncode ownConnReq
else createItems mCt m then joinExistingContact subMode mCt
else joinExistingContact subMode mCt else createItems mCt m
else joinExistingContact subMode mCt
where where
joinExistingContact subMode mCt = do joinExistingContact subMode mCt = do
connIds <- joinConn subMode connIds <- joinConn subMode
mCt' <- withStore' $ \db -> updateMemberContactInvited db user connIds g mConn mCt subMode mCt' <- withStore $ \db -> updateMemberContactInvited db user connIds g mConn mCt subMode
createItems mCt' m createItems mCt' m
securityCodeChanged mCt' securityCodeChanged mCt'
createNewContact subMode = do createNewContact subMode = do
@ -5054,7 +5085,7 @@ parseFileDescription =
sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m () sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m ()
sendDirectFileInline ct ft sharedMsgId = do sendDirectFileInline ct ft sharedMsgId = do
msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage ct msgDeliveryId <- sendFileInline_ ft sharedMsgId $ sendDirectContactMessage ct
withStore' $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId withStore $ \db -> updateSndDirectFTDelivery db ct ft msgDeliveryId
sendMemberFileInline :: ChatMonad m => GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> m () sendMemberFileInline :: ChatMonad m => GroupMember -> Connection -> FileTransferMeta -> SharedMsgId -> m ()
sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do sendMemberFileInline m@GroupMember {groupId} conn ft sharedMsgId = do
@ -5247,7 +5278,8 @@ deleteOrUpdateMemberRecord user@User {userId} member =
Nothing -> deleteGroupMember db user member Nothing -> deleteGroupMember db user member
sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64) sendDirectContactMessage :: (MsgEncodingI e, ChatMonad m) => Contact -> ChatMsgEvent e -> m (SndMessage, Int64)
sendDirectContactMessage ct@Contact {activeConn = conn@Connection {connId, connStatus}, contactStatus} chatMsgEvent sendDirectContactMessage ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotReady ct
sendDirectContactMessage ct@Contact {activeConn = Just conn@Connection {connId, connStatus}, contactStatus} chatMsgEvent
| connStatus /= ConnReady && connStatus /= ConnSndReady = throwChatError $ CEContactNotReady ct | connStatus /= ConnReady && connStatus /= ConnSndReady = throwChatError $ CEContactNotReady ct
| contactStatus /= CSActive = throwChatError $ CEContactNotActive ct | contactStatus /= CSActive = throwChatError $ CEContactNotActive ct
| connDisabled conn = throwChatError $ CEContactDisabled ct | connDisabled conn = throwChatError $ CEContactDisabled ct

5
src/Simplex/Chat/Controller.hs
View File

@ -436,7 +436,7 @@ data ChatResponse
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure} | CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64} | CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
| CRNetworkConfig {networkConfig :: NetworkConfig} | CRNetworkConfig {networkConfig :: NetworkConfig}
| CRContactInfo {user :: User, contact :: Contact, connectionStats :: ConnectionStats, customUserProfile :: Maybe Profile} | CRContactInfo {user :: User, contact :: Contact, connectionStats_ :: Maybe ConnectionStats, customUserProfile :: Maybe Profile}
| CRGroupInfo {user :: User, groupInfo :: GroupInfo, groupSummary :: GroupSummary} | CRGroupInfo {user :: User, groupInfo :: GroupInfo, groupSummary :: GroupSummary}
| CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats} | CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
| CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats} | CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats}
@ -1064,7 +1064,8 @@ chatModifyVar f newValue = asks f >>= atomically . (`modifyTVar'` newValue)
{-# INLINE chatModifyVar #-} {-# INLINE chatModifyVar #-}
setContactNetworkStatus :: ChatMonad' m => Contact -> NetworkStatus -> m () setContactNetworkStatus :: ChatMonad' m => Contact -> NetworkStatus -> m ()
setContactNetworkStatus ct = chatModifyVar connNetworkStatuses . M.insert (contactAgentConnId ct) setContactNetworkStatus Contact {activeConn = Nothing} _ = pure ()
setContactNetworkStatus Contact {activeConn = Just Connection {agentConnId}} status = chatModifyVar connNetworkStatuses $ M.insert agentConnId status
tryChatError :: ChatMonad m => m a -> m (Either ChatError a) tryChatError :: ChatMonad m => m a -> m (Either ChatError a)
tryChatError = tryAllErrors mkChatError tryChatError = tryAllErrors mkChatError

2
src/Simplex/Chat/Protocol.hs
View File

@ -82,7 +82,7 @@ instance ToJSON ConnectionEntity where
updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity
updateEntityConnStatus connEntity connStatus = case connEntity of updateEntityConnStatus connEntity connStatus = case connEntity of
RcvDirectMsgConnection c ct_ -> RcvDirectMsgConnection (st c) ((\ct -> (ct :: Contact) {activeConn = st c}) <$> ct_) RcvDirectMsgConnection c ct_ -> RcvDirectMsgConnection (st c) ((\ct -> (ct :: Contact) {activeConn = Just $ st c}) <$> ct_)
RcvGroupMsgConnection c gInfo m@GroupMember {activeConn = c'} -> RcvGroupMsgConnection (st c) gInfo m {activeConn = st <$> c'} RcvGroupMsgConnection c gInfo m@GroupMember {activeConn = c'} -> RcvGroupMsgConnection (st c) gInfo m {activeConn = st <$> c'}
SndFileConnection c ft -> SndFileConnection (st c) ft SndFileConnection c ft -> SndFileConnection (st c) ft
RcvFileConnection c ft -> RcvFileConnection (st c) ft RcvFileConnection c ft -> RcvFileConnection (st c) ft

5
src/Simplex/Chat/Store/Connections.hs
View File

@ -81,10 +81,11 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|] |]
(userId, contactId) (userId, contactId)
toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact toContact' :: Int64 -> Connection -> [(ProfileId, ContactName, Text, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Maybe Int64, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)] -> Either StoreError Contact
toContact' contactId activeConn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)] = toContact' contactId conn [(profileId, localDisplayName, displayName, fullName, image, contactLink, localAlias, viaGroup, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)] =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn 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} in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found" toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember) getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)

37
src/Simplex/Chat/Store/Direct.hs
View File

@ -194,13 +194,13 @@ createIncognitoProfile db User {userId} p = do
createIncognitoProfile_ db userId createdAt p createIncognitoProfile_ db userId createdAt p
createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact createDirectContact :: DB.Connection -> User -> Connection -> Profile -> ExceptT StoreError IO Contact
createDirectContact db user@User {userId} activeConn@Connection {connId, localAlias} p@Profile {preferences} = do createDirectContact db user@User {userId} conn@Connection {connId, localAlias} p@Profile {preferences} = do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
(localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt) (localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt)
let profile = toLocalProfile profileId p localAlias let profile = toLocalProfile profileId p localAlias
userPreferences = emptyChatPrefs userPreferences = emptyChatPrefs
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
pure $ Contact {contactId, localDisplayName, profile, activeConn, viaGroup = Nothing, contactUsed = False, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False} pure $ Contact {contactId, localDisplayName, profile, activeConn = Just conn, viaGroup = Nothing, contactUsed = False, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt, updatedAt = createdAt, chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False}
deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO () deleteContactConnectionsAndFiles :: DB.Connection -> UserId -> Contact -> IO ()
deleteContactConnectionsAndFiles db userId Contact {contactId} = do deleteContactConnectionsAndFiles db userId Contact {contactId} = do
@ -218,7 +218,7 @@ deleteContactConnectionsAndFiles db userId Contact {contactId} = do
DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId) DB.execute db "DELETE FROM files WHERE user_id = ? AND contact_id = ?" (userId, contactId)
deleteContact :: DB.Connection -> User -> Contact -> IO () deleteContact :: DB.Connection -> User -> Contact -> IO ()
deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do deleteContact db user@User {userId} Contact {contactId, localDisplayName, activeConn} = do
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId) ctMember :: (Maybe ContactId) <- maybeFirstRow fromOnly $ DB.query db "SELECT contact_id FROM group_members WHERE user_id = ? AND contact_id = ? LIMIT 1" (userId, contactId)
if isNothing ctMember if isNothing ctMember
@ -229,16 +229,20 @@ deleteContact db user@User {userId} Contact {contactId, localDisplayName, active
currentTs <- getCurrentTime currentTs <- getCurrentTime
DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId) DB.execute db "UPDATE group_members SET contact_id = NULL, updated_at = ? WHERE user_id = ? AND contact_id = ?" (currentTs, userId, contactId)
DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId forM_ activeConn $ \Connection {customUserProfileId} ->
forM_ customUserProfileId $ \profileId ->
deleteUnusedIncognitoProfileById_ db user profileId
-- should only be used if contact is not member of any groups -- should only be used if contact is not member of any groups
deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO () deleteContactWithoutGroups :: DB.Connection -> User -> Contact -> IO ()
deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn = Connection {customUserProfileId}} = do deleteContactWithoutGroups db user@User {userId} Contact {contactId, localDisplayName, activeConn} = do
DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND contact_id = ?" (userId, contactId)
deleteContactProfile_ db userId contactId deleteContactProfile_ db userId contactId
DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName) DB.execute db "DELETE FROM display_names WHERE user_id = ? AND local_display_name = ?" (userId, localDisplayName)
DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId) DB.execute db "DELETE FROM contacts WHERE user_id = ? AND contact_id = ?" (userId, contactId)
forM_ customUserProfileId $ \profileId -> deleteUnusedIncognitoProfileById_ db user profileId forM_ activeConn $ \Connection {customUserProfileId} ->
forM_ customUserProfileId $ \profileId ->
deleteUnusedIncognitoProfileById_ db user profileId
setContactDeleted :: DB.Connection -> User -> Contact -> IO () setContactDeleted :: DB.Connection -> User -> Contact -> IO ()
setContactDeleted db User {userId} Contact {contactId} = do setContactDeleted db User {userId} Contact {contactId} = do
@ -307,19 +311,19 @@ updateContactProfile db user@User {userId} c p'
updateContact_ db userId contactId localDisplayName ldn currentTs updateContact_ db userId contactId localDisplayName ldn currentTs
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences} pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
where where
Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, activeConn, userPreferences} = c Contact {contactId, localDisplayName, profile = LocalProfile {profileId, displayName, localAlias}, userPreferences} = c
Profile {displayName = newName, preferences} = p' Profile {displayName = newName, preferences} = p'
profile = toLocalProfile profileId p' localAlias profile = toLocalProfile profileId p' localAlias
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn mergedPreferences = contactUserPreferences user userPreferences preferences $ contactConnIncognito c
updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact updateContactUserPreferences :: DB.Connection -> User -> Contact -> Preferences -> IO Contact
updateContactUserPreferences db user@User {userId} c@Contact {contactId, activeConn} userPreferences = do updateContactUserPreferences db user@User {userId} c@Contact {contactId} userPreferences = do
updatedAt <- getCurrentTime updatedAt <- getCurrentTime
DB.execute DB.execute
db db
"UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?" "UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
(userPreferences, updatedAt, userId, contactId) (userPreferences, updatedAt, userId, contactId)
let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ connIncognito activeConn let mergedPreferences = contactUserPreferences user userPreferences (preferences' c) $ contactConnIncognito c
pure $ c {mergedPreferences, userPreferences} pure $ c {mergedPreferences, userPreferences}
updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact updateContactAlias :: DB.Connection -> UserId -> Contact -> LocalAlias -> IO Contact
@ -453,7 +457,8 @@ getContactByName db user localDisplayName = do
getUserContacts :: DB.Connection -> User -> IO [Contact] getUserContacts :: DB.Connection -> User -> IO [Contact]
getUserContacts db user@User {userId} = do getUserContacts db user@User {userId} = do
contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId) contactIds <- map fromOnly <$> DB.query db "SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0" (Only userId)
rights <$> mapM (runExceptT . getContact db user) contactIds contacts <- rights <$> mapM (runExceptT . getContact db user) contactIds
pure $ filter (\Contact {activeConn} -> isJust activeConn) contacts
createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> VersionRange -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest createOrUpdateContactRequest :: DB.Connection -> User -> Int64 -> InvitationId -> VersionRange -> Profile -> Maybe XContactId -> ExceptT StoreError IO ContactOrRequest
createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ = createOrUpdateContactRequest db user@User {userId} userContactLinkId invId (VersionRange minV maxV) Profile {displayName, fullName, image, contactLink, preferences} xContactId_ =
@ -642,9 +647,9 @@ createAcceptedContact db user@User {userId, profile = LocalProfile {preferences}
"INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)" "INSERT INTO contacts (user_id, local_display_name, contact_profile_id, enable_ntfs, user_preferences, created_at, updated_at, chat_ts, xcontact_id) VALUES (?,?,?,?,?,?,?,?,?)"
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId) (userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId)
contactId <- insertedRowId db contactId <- insertedRowId db
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode conn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn, viaGroup = Nothing, contactUsed = False, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False} pure $ Contact {contactId, localDisplayName, profile = toLocalProfile profileId profile "", activeConn = Just conn, viaGroup = Nothing, contactUsed = False, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = createdAt, updatedAt = createdAt, chatTs = Just createdAt, contactGroupMemberId = Nothing, contactGrpInvSent = False}
getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64 getContactIdByName :: DB.Connection -> User -> ContactName -> ExceptT StoreError IO Int64
getContactIdByName db User {userId} cName = getContactIdByName db User {userId} cName =
@ -656,7 +661,7 @@ getContact db user contactId = getContact_ db user contactId False
getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact getContact_ :: DB.Connection -> User -> Int64 -> Bool -> ExceptT StoreError IO Contact
getContact_ db user@User {userId} contactId deleted = getContact_ db user@User {userId} contactId deleted =
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $ ExceptT . firstRow (toContact user) (SEContactNotFound contactId) $
DB.query DB.query
db db
[sql| [sql|

10
src/Simplex/Chat/Store/Files.hs
View File

@ -207,8 +207,9 @@ createSndGroupFileTransferConnection db user@User {userId} fileId (cmdId, acId)
"INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)" "INSERT INTO snd_files (file_id, file_status, connection_id, group_member_id, created_at, updated_at) VALUES (?,?,?,?,?,?)"
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs) (fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> ExceptT StoreError IO SndFileTransfer
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do createSndDirectInlineFT _ Contact {localDisplayName, activeConn = Nothing} _ = throwError $ SEContactNotReady localDisplayName
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Just Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = liftIO $ do
currentTs <- getCurrentTime currentTs <- getCurrentTime
let fileStatus = FSConnected let fileStatus = FSConnected
fileInline' = Just $ fromMaybe IFMOffer fileInline fileInline' = Just $ fromMaybe IFMOffer fileInline
@ -229,8 +230,9 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
(fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs) (fileId, fileStatus, fileInline', connId, groupMemberId, currentTs, currentTs)
pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'} pure SndFileTransfer {fileId, fileName, filePath, fileSize, chunkSize, recipientDisplayName = n, connId, agentConnId, groupMemberId = Just groupMemberId, fileStatus, fileDescrId = Nothing, fileInline = fileInline'}
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO () updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $
DB.execute DB.execute
db db
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL" "UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"

27
src/Simplex/Chat/Store/Groups.hs
View File

@ -314,7 +314,8 @@ createNewGroup db gVar user@User {userId} groupProfile incognitoProfile = Except
-- | creates a new group record for the group the current user was invited to, or returns an existing one -- | creates a new group record for the group the current user was invited to, or returns an existing one
createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId) createGroupInvitation :: DB.Connection -> User -> Contact -> GroupInvitation -> Maybe ProfileId -> ExceptT StoreError IO (GroupInfo, GroupMemberId)
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do createGroupInvitation _ _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
createGroupInvitation db user@User {userId} contact@Contact {contactId, activeConn = Just Connection {customUserProfileId}} GroupInvitation {fromMember, invitedMember, connRequest, groupProfile} incognitoProfileId = do
liftIO getInvitationGroupId_ >>= \case liftIO getInvitationGroupId_ >>= \case
Nothing -> createGroupInvitation_ Nothing -> createGroupInvitation_
Just gId -> do Just gId -> do
@ -705,7 +706,8 @@ getGroupInvitation db user groupId =
DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId) DB.query db "SELECT g.inv_queue_info FROM groups g WHERE g.group_id = ? AND g.user_id = ?" (groupId, userId)
createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember createNewContactMember :: DB.Connection -> TVar ChaChaDRG -> User -> GroupId -> Contact -> GroupMemberRole -> ConnId -> ConnReqInvitation -> SubscriptionMode -> ExceptT StoreError IO GroupMember
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Connection {peerChatVRange}} memberRole agentConnId connRequest subMode = createNewContactMember _ _ _ _ Contact {localDisplayName, activeConn = Nothing} _ _ _ _ = throwError $ SEContactNotReady localDisplayName
createNewContactMember db gVar User {userId, userContactId} groupId Contact {contactId, localDisplayName, profile, activeConn = Just Connection {peerChatVRange}} memberRole agentConnId connRequest subMode =
createWithRandomId gVar $ \memId -> do createWithRandomId gVar $ \memId -> do
createdAt <- liftIO getCurrentTime createdAt <- liftIO getCurrentTime
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
@ -1725,15 +1727,15 @@ createMemberContact
connId <- insertedRowId db connId <- insertedRowId db
let ctConn = Connection {connId, agentConnId = AgentConnId acId, peerChatVRange, connType = ConnContact, contactConnInitiated = True, entityId = Just contactId, viaContact = Nothing, viaUserContactLink = Nothing, viaGroupLink = False, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0} let ctConn = Connection {connId, agentConnId = AgentConnId acId, peerChatVRange, connType = ConnContact, contactConnInitiated = True, entityId = Just contactId, viaContact = Nothing, viaUserContactLink = Nothing, viaGroupLink = False, groupLinkId = Nothing, customUserProfileId, connLevel, connStatus = ConnNew, localAlias = "", createdAt = currentTs, connectionCode = Nothing, authErrCounter = 0}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
pure Contact {contactId, localDisplayName, profile = memberProfile, activeConn = ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Just groupMemberId, contactGrpInvSent = False} 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}
getMemberContact :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation) getMemberContact :: DB.Connection -> User -> ContactId -> ExceptT StoreError IO (GroupInfo, GroupMember, Contact, ConnReqInvitation)
getMemberContact db user contactId = do getMemberContact db user contactId = do
ct <- getContact db user contactId ct <- getContact db user contactId
let Contact {contactGroupMemberId, activeConn = Connection {connId}} = ct let Contact {contactGroupMemberId, activeConn} = ct
cReq <- getConnReqInv db connId case (activeConn, contactGroupMemberId) of
case contactGroupMemberId of (Just Connection {connId}, Just groupMemberId) -> do
Just groupMemberId -> do cReq <- getConnReqInv db connId
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
g <- getGroupInfo db user groupId g <- getGroupInfo db user groupId
pure (g, m, ct, cReq) pure (g, m, ct, cReq)
@ -1762,7 +1764,7 @@ createMemberContactInvited
contactId <- createContactUpdateMember currentTs userPreferences contactId <- createContactUpdateMember currentTs userPreferences
ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = ctConn, viaGroup = Nothing, contactUsed = True, contactStatus = CSActive, chatSettings = defaultChatSettings, userPreferences, mergedPreferences, createdAt = currentTs, updatedAt = currentTs, chatTs = Just currentTs, contactGroupMemberId = Nothing, contactGrpInvSent = False} 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}
m' = m {memberContactId = Just contactId} m' = m {memberContactId = Just contactId}
pure (mCt', m') pure (mCt', m')
where where
@ -1786,13 +1788,14 @@ createMemberContactInvited
(contactId, currentTs, groupMemberId) (contactId, currentTs, groupMemberId)
pure contactId pure contactId
updateMemberContactInvited :: DB.Connection -> User -> (CommandId, ConnId) -> GroupInfo -> Connection -> Contact -> SubscriptionMode -> IO Contact updateMemberContactInvited :: DB.Connection -> User -> (CommandId, ConnId) -> GroupInfo -> Connection -> Contact -> SubscriptionMode -> ExceptT StoreError IO Contact
updateMemberContactInvited db user connIds gInfo mConn ct@Contact {contactId, activeConn = oldContactConn} subMode = do updateMemberContactInvited _ _ _ _ _ Contact {localDisplayName, activeConn = Nothing} _ = throwError $ SEContactNotReady localDisplayName
updateMemberContactInvited db user connIds gInfo mConn ct@Contact {contactId, activeConn = Just oldContactConn} subMode = liftIO $ do
updateConnectionStatus db oldContactConn ConnDeleted updateConnectionStatus db oldContactConn ConnDeleted
activeConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode activeConn' <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode
ct' <- updateContactStatus db user ct CSActive ct' <- updateContactStatus db user ct CSActive
ct'' <- resetMemberContactFields db ct' ct'' <- resetMemberContactFields db ct'
pure (ct'' :: Contact) {activeConn} pure (ct'' :: Contact) {activeConn = Just activeConn'}
resetMemberContactFields :: DB.Connection -> Contact -> IO Contact resetMemberContactFields :: DB.Connection -> Contact -> IO Contact
resetMemberContactFields db ct@Contact {contactId} = do resetMemberContactFields db ct@Contact {contactId} = do

32
src/Simplex/Chat/Store/Messages.hs
View File

@ -497,7 +497,7 @@ getDirectChatPreviews_ db user@User {userId} = do
ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent
FROM contacts ct FROM contacts ct
JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id JOIN contact_profiles cp ON ct.contact_profile_id = cp.contact_profile_id
JOIN connections c ON c.contact_id = ct.contact_id LEFT JOIN connections c ON c.contact_id = ct.contact_id
LEFT JOIN ( LEFT JOIN (
SELECT contact_id, MAX(chat_item_id) AS MaxId SELECT contact_id, MAX(chat_item_id) AS MaxId
FROM chat_items FROM chat_items
@ -514,25 +514,31 @@ getDirectChatPreviews_ db user@User {userId} = do
) ChatStats ON ChatStats.contact_id = ct.contact_id ) ChatStats ON ChatStats.contact_id = ct.contact_id
LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id LEFT JOIN chat_items ri ON ri.user_id = i.user_id AND ri.contact_id = i.contact_id AND ri.shared_msg_id = i.quoted_shared_msg_id
WHERE ct.user_id = ? WHERE ct.user_id = ?
AND ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1) AND ct.is_user = 0
AND ct.deleted = 0 AND ct.deleted = 0
AND c.connection_id = ( AND (
SELECT cc_connection_id FROM ( (
SELECT ((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1)
cc.connection_id AS cc_connection_id, AND c.connection_id = (
cc.created_at AS cc_created_at, SELECT cc_connection_id FROM (
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord SELECT
FROM connections cc cc.connection_id AS cc_connection_id,
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id cc.created_at AS cc_created_at,
ORDER BY cc_conn_status_ord DESC, cc_created_at DESC (CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
LIMIT 1 FROM connections cc
WHERE cc.user_id = ct.user_id AND cc.contact_id = ct.contact_id
ORDER BY cc_conn_status_ord DESC, cc_created_at DESC
LIMIT 1
)
)
) )
OR c.connection_id IS NULL
) )
ORDER BY i.item_ts DESC ORDER BY i.item_ts DESC
|] |]
(CISRcvNew, userId, ConnReady, ConnSndReady) (CISRcvNew, userId, ConnReady, ConnSndReady)
where where
toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat toDirectChatPreview :: UTCTime -> ContactRow :. MaybeConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) = toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) =
let contact = toContact user $ contactRow :. connRow let contact = toContact user $ contactRow :. connRow
ci_ = toDirectChatItemList currentTs ciRow_ ci_ = toDirectChatItemList currentTs ciRow_

17
src/Simplex/Chat/Store/Shared.hs
View File

@ -254,24 +254,15 @@ deleteUnusedIncognitoProfileById_ db User {userId} profileId =
type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool) type ContactRow = (ContactId, ProfileId, ContactName, Maybe Int64, ContactName, Text, Maybe ImageData, Maybe ConnReqContact, LocalAlias, Bool, ContactStatus) :. (Maybe MsgFilter, Maybe Bool, Bool, Maybe Preferences, Preferences, UTCTime, UTCTime, Maybe UTCTime, Maybe GroupMemberId, Bool)
toContact :: User -> ContactRow :. ConnectionRow -> Contact toContact :: User -> ContactRow :. MaybeConnectionRow -> Contact
toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) = toContact user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias} let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
activeConn = toConnection connRow activeConn = toMaybeConnection connRow
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite} chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn 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} in Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
toContactOrError :: User -> ContactRow :. MaybeConnectionRow -> Either StoreError Contact
toContactOrError user (((contactId, profileId, localDisplayName, viaGroup, displayName, fullName, image, contactLink, localAlias, contactUsed, contactStatus) :. (enableNtfs_, sendRcpts, favorite, preferences, userPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent)) :. connRow) =
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
chatSettings = ChatSettings {enableNtfs = fromMaybe MFAll enableNtfs_, sendRcpts, favorite}
in case toMaybeConnection connRow of
Just activeConn ->
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
in Right Contact {contactId, localDisplayName, profile, activeConn, viaGroup, contactUsed, contactStatus, chatSettings, userPreferences, mergedPreferences, createdAt, updatedAt, chatTs, contactGroupMemberId, contactGrpInvSent}
_ -> Left $ SEContactNotReady localDisplayName
getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile getProfileById :: DB.Connection -> UserId -> Int64 -> ExceptT StoreError IO LocalProfile
getProfileById db userId profileId = getProfileById db userId profileId =
ExceptT . firstRow toProfile (SEProfileNotFound profileId) $ ExceptT . firstRow toProfile (SEProfileNotFound profileId) $

23
src/Simplex/Chat/Types.hs
View File

@ -170,7 +170,7 @@ data Contact = Contact
{ contactId :: ContactId, { contactId :: ContactId,
localDisplayName :: ContactName, localDisplayName :: ContactName,
profile :: LocalProfile, profile :: LocalProfile,
activeConn :: Connection, activeConn :: Maybe Connection,
viaGroup :: Maybe Int64, viaGroup :: Maybe Int64,
contactUsed :: Bool, contactUsed :: Bool,
contactStatus :: ContactStatus, contactStatus :: ContactStatus,
@ -189,32 +189,31 @@ instance ToJSON Contact where
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True} toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True} toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
contactConn :: Contact -> Connection contactConn :: Contact -> Maybe Connection
contactConn Contact {activeConn} = activeConn contactConn Contact {activeConn} = activeConn
contactAgentConnId :: Contact -> AgentConnId contactConnId :: Contact -> Maybe ConnId
contactAgentConnId Contact {activeConn = Connection {agentConnId}} = agentConnId contactConnId c = aConnId <$> contactConn c
contactConnId :: Contact -> ConnId
contactConnId = aConnId . contactConn
type IncognitoEnabled = Bool type IncognitoEnabled = Bool
contactConnIncognito :: Contact -> IncognitoEnabled contactConnIncognito :: Contact -> IncognitoEnabled
contactConnIncognito = connIncognito . contactConn contactConnIncognito = maybe False connIncognito . contactConn
contactDirect :: Contact -> Bool contactDirect :: Contact -> Bool
contactDirect Contact {activeConn = Connection {connLevel, viaGroupLink}} = connLevel == 0 && not viaGroupLink contactDirect Contact {activeConn} = maybe True direct activeConn
where
direct Connection {connLevel, viaGroupLink} = connLevel == 0 && not viaGroupLink
directOrUsed :: Contact -> Bool directOrUsed :: Contact -> Bool
directOrUsed ct@Contact {contactUsed} = directOrUsed ct@Contact {contactUsed} =
contactDirect ct || contactUsed contactDirect ct || contactUsed
anyDirectOrUsed :: Contact -> Bool anyDirectOrUsed :: Contact -> Bool
anyDirectOrUsed Contact {contactUsed, activeConn = Connection {connLevel}} = connLevel == 0 || contactUsed anyDirectOrUsed Contact {contactUsed, activeConn} = ((\c -> c.connLevel) <$> activeConn) == Just 0 || contactUsed
contactReady :: Contact -> Bool contactReady :: Contact -> Bool
contactReady Contact {activeConn} = connReady activeConn contactReady Contact {activeConn} = maybe False connReady activeConn
contactActive :: Contact -> Bool contactActive :: Contact -> Bool
contactActive Contact {contactStatus} = contactStatus == CSActive contactActive Contact {contactStatus} = contactStatus == CSActive
@ -223,7 +222,7 @@ contactDeleted :: Contact -> Bool
contactDeleted Contact {contactStatus} = contactStatus == CSDeleted contactDeleted Contact {contactStatus} = contactStatus == CSDeleted
contactSecurityCode :: Contact -> Maybe SecurityCode contactSecurityCode :: Contact -> Maybe SecurityCode
contactSecurityCode Contact {activeConn} = connectionCode activeConn contactSecurityCode Contact {activeConn} = connectionCode =<< activeConn
data ContactStatus data ContactStatus
= CSActive = CSActive

16
src/Simplex/Chat/View.hs
View File

@ -137,9 +137,11 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
CRGroupsList u gs -> ttyUser u $ viewGroupsList gs CRGroupsList u gs -> ttyUser u $ viewGroupsList gs
CRSentGroupInvitation u g c _ -> CRSentGroupInvitation u g c _ ->
ttyUser u $ ttyUser u $
if viaGroupLink . contactConn $ c case contactConn c of
then [ttyContact' c <> " invited to group " <> ttyGroup' g <> " via your group link"] Just Connection {viaGroupLink}
else ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c] | viaGroupLink -> [ttyContact' c <> " invited to group " <> ttyGroup' g <> " via your group link"]
| otherwise -> ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c]
Nothing -> []
CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus CRFileTransferStatus u ftStatus -> ttyUser u $ viewFileTransferStatus ftStatus
CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci
CRUserProfile u p -> ttyUser u $ viewUserProfile p CRUserProfile u p -> ttyUser u $ viewUserProfile p
@ -325,7 +327,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
testViewChats chats = [sShow $ map toChatView chats] testViewChats chats = [sShow $ map toChatView chats]
where where
toChatView :: AChat -> (Text, Text, Maybe ConnStatus) toChatView :: AChat -> (Text, Text, Maybe ConnStatus)
toChatView (AChat _ (Chat (DirectChat Contact {localDisplayName, activeConn}) items _)) = ("@" <> localDisplayName, toCIPreview items Nothing, Just $ connStatus activeConn) toChatView (AChat _ (Chat (DirectChat Contact {localDisplayName, activeConn}) items _)) = ("@" <> localDisplayName, toCIPreview items Nothing, connStatus <$> activeConn)
toChatView (AChat _ (Chat (GroupChat GroupInfo {membership, localDisplayName}) items _)) = ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing) toChatView (AChat _ (Chat (GroupChat GroupInfo {membership, localDisplayName}) items _)) = ("#" <> localDisplayName, toCIPreview items (Just membership), Nothing)
toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing) toChatView (AChat _ (Chat (ContactRequest UserContactRequest {localDisplayName}) items _)) = ("<@" <> localDisplayName, toCIPreview items Nothing, Nothing)
toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus) toChatView (AChat _ (Chat (ContactConnection PendingContactConnection {pccConnId, pccConnStatus}) items _)) = (":" <> T.pack (show pccConnId), toCIPreview items Nothing, Just pccConnStatus)
@ -1038,10 +1040,10 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
"use " <> highlight' "/network socks=<on/off/[ipv4]:port>[ timeout=<seconds>]" <> " to change settings" "use " <> highlight' "/network socks=<on/off/[ipv4]:port>[ timeout=<seconds>]" <> " to change settings"
] ]
viewContactInfo :: Contact -> ConnectionStats -> Maybe Profile -> [StyledString] viewContactInfo :: Contact -> Maybe ConnectionStats -> Maybe Profile -> [StyledString]
viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn} stats incognitoProfile = viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, contactLink}, activeConn} stats incognitoProfile =
["contact ID: " <> sShow contactId] ["contact ID: " <> sShow contactId]
<> viewConnectionStats stats <> maybe [] viewConnectionStats stats
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink <> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
<> maybe <> maybe
["you've shared main profile with this contact"] ["you've shared main profile with this contact"]
@ -1049,7 +1051,7 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta
incognitoProfile incognitoProfile
<> ["alias: " <> plain localAlias | localAlias /= ""] <> ["alias: " <> plain localAlias | localAlias /= ""]
<> [viewConnectionVerified (contactSecurityCode ct)] <> [viewConnectionVerified (contactSecurityCode ct)]
<> [viewPeerChatVRange (peerChatVRange activeConn)] <> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString] viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
viewGroupInfo GroupInfo {groupId} s = viewGroupInfo GroupInfo {groupId} s =