core: contacts without connections (#3313)
* 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
GitHub
parent
3d7258fa58
commit
4816150b99
@ -62,7 +62,8 @@ broadcastBot BroadcastBotOpts {publishers, welcomeMessage, prohibitedMessage} _u
|
||||
MCLink {} -> True
|
||||
MCImage {} -> True
|
||||
_ -> 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)
|
||||
&& not (connDisabled conn)
|
||||
&& contactId' ct' /= contactId' ct
|
||||
|
||||
@ -614,8 +614,8 @@ processChatCommand = \case
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileDigest = Nothing, fileConnReq, fileInline, fileDescr = Nothing}
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
withStore' $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize subMode
|
||||
withStore $ \db -> do
|
||||
ft@FileTransferMeta {fileId} <- liftIO $ createSndDirectFileTransfer db userId ct file fileInvitation agentConnId_ chSize subMode
|
||||
fileStatus <- case fileInline of
|
||||
Just IFMSent -> createSndDirectInlineFT db ct ft $> CIFSSndTransfer 0 1
|
||||
_ -> pure CIFSSndStored
|
||||
@ -749,7 +749,8 @@ processChatCommand = \case
|
||||
let fileSource = Just $ CryptoFile filePath cfArgs
|
||||
ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP}
|
||||
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))
|
||||
where
|
||||
-- we are not sending files to pending members, same as with inline files
|
||||
@ -1190,7 +1191,8 @@ processChatCommand = \case
|
||||
ct <- getContact db user chatId
|
||||
liftIO $ updateContactSettings db user chatId chatSettings
|
||||
pure ct
|
||||
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings)
|
||||
forM_ (contactConnId ct) $ \connId ->
|
||||
withAgent $ \a -> toggleConnectionNtfs a connId (chatHasNtfs chatSettings)
|
||||
ok user
|
||||
CTGroup -> do
|
||||
ms <- withStore $ \db -> do
|
||||
@ -1211,9 +1213,12 @@ processChatCommand = \case
|
||||
ok user
|
||||
APIContactInfo contactId -> withUser $ \user@User {userId} -> do
|
||||
-- [incognito] print user's incognito profile for this contact
|
||||
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
connectionStats <- withAgent (`getConnectionServers` contactConnId ct)
|
||||
ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
incognitoProfile <- case activeConn of
|
||||
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)
|
||||
APIGroupInfo gId -> withUser $ \user -> do
|
||||
(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
|
||||
APISwitchContact contactId -> withUser $ \user -> do
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
connectionStats <- withAgent $ \a -> switchConnectionAsync a "" $ contactConnId ct
|
||||
pure $ CRContactSwitchStarted user ct connectionStats
|
||||
case contactConnId ct of
|
||||
Just connId -> do
|
||||
connectionStats <- withAgent $ \a -> switchConnectionAsync a "" connId
|
||||
pure $ CRContactSwitchStarted user ct connectionStats
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APISwitchGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
@ -1235,8 +1243,11 @@ processChatCommand = \case
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APIAbortSwitchContact contactId -> withUser $ \user -> do
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
connectionStats <- withAgent $ \a -> abortConnectionSwitch a $ contactConnId ct
|
||||
pure $ CRContactSwitchAborted user ct connectionStats
|
||||
case contactConnId ct of
|
||||
Just connId -> do
|
||||
connectionStats <- withAgent $ \a -> abortConnectionSwitch a connId
|
||||
pure $ CRContactSwitchAborted user ct connectionStats
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIAbortSwitchGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
@ -1246,9 +1257,12 @@ processChatCommand = \case
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APISyncContactRatchet contactId force -> withUser $ \user -> do
|
||||
ct <- withStore $ \db -> getContact db user contactId
|
||||
cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a (contactConnId ct) force
|
||||
createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCERatchetSync rss Nothing) Nothing
|
||||
pure $ CRContactRatchetSyncStarted user ct cStats
|
||||
case contactConnId ct of
|
||||
Just connId -> do
|
||||
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
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
case memberConnId m of
|
||||
@ -1258,16 +1272,19 @@ processChatCommand = \case
|
||||
pure $ CRGroupMemberRatchetSyncStarted user g m cStats
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APIGetContactCode contactId -> withUser $ \user -> do
|
||||
ct@Contact {activeConn = conn@Connection {connId}} <- withStore $ \db -> getContact db user contactId
|
||||
code <- getConnectionCode (contactConnId ct)
|
||||
ct' <- case contactSecurityCode ct of
|
||||
Just SecurityCode {securityCode}
|
||||
| sameVerificationCode code securityCode -> pure ct
|
||||
| otherwise -> do
|
||||
withStore' $ \db -> setConnectionVerified db user connId Nothing
|
||||
pure (ct :: Contact) {activeConn = conn {connectionCode = Nothing}}
|
||||
_ -> pure ct
|
||||
pure $ CRContactCode user ct' code
|
||||
ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
case activeConn of
|
||||
Just conn@Connection {connId} -> do
|
||||
code <- getConnectionCode $ aConnId conn
|
||||
ct' <- case contactSecurityCode ct of
|
||||
Just SecurityCode {securityCode}
|
||||
| sameVerificationCode code securityCode -> pure ct
|
||||
| otherwise -> do
|
||||
withStore' $ \db -> setConnectionVerified db user connId Nothing
|
||||
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
|
||||
(g, m@GroupMember {activeConn}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
case activeConn of
|
||||
@ -1283,17 +1300,22 @@ processChatCommand = \case
|
||||
pure $ CRGroupMemberCode user g m' code
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APIVerifyContact contactId code -> withUser $ \user -> do
|
||||
Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
verifyConnectionCode user activeConn code
|
||||
ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
case activeConn of
|
||||
Just conn -> verifyConnectionCode user conn code
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIVerifyGroupMember gId gMemberId code -> withUser $ \user -> do
|
||||
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId
|
||||
case activeConn of
|
||||
Just conn -> verifyConnectionCode user conn code
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
APIEnableContact contactId -> withUser $ \user -> do
|
||||
Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
withStore' $ \db -> setConnectionAuthErrCounter db user activeConn 0
|
||||
ok user
|
||||
ct@Contact {activeConn} <- withStore $ \db -> getContact db user contactId
|
||||
case activeConn of
|
||||
Just conn -> do
|
||||
withStore' $ \db -> setConnectionAuthErrCounter db user conn 0
|
||||
ok user
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
APIEnableGroupMember gId gMemberId -> withUser $ \user -> do
|
||||
GroupMember {activeConn} <- withStore $ \db -> getGroupMember db user gId gMemberId
|
||||
case activeConn of
|
||||
@ -1554,16 +1576,19 @@ processChatCommand = \case
|
||||
inv@ReceivedGroupInvitation {fromMember} <- getGroupInvitation db user groupId
|
||||
(inv,) <$> getContactViaMember db user fromMember
|
||||
let ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} = invitation
|
||||
Contact {activeConn = Connection {peerChatVRange}} = ct
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt membership.memberId
|
||||
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
|
||||
Contact {activeConn} = ct
|
||||
case activeConn of
|
||||
Just Connection {peerChatVRange} -> do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt membership.memberId
|
||||
agentConnId <- withAgent $ \a -> joinConnection a (aUserId user) True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
createMemberConnection db userId fromMember agentConnId (fromJVersionRange peerChatVRange) subMode
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
pure $ CRUserAcceptedGroupSent user g {membership = membership {memberStatus = GSMemAccepted}} Nothing
|
||||
Nothing -> throwChatError $ CEContactNotActive ct
|
||||
where
|
||||
updateCIGroupInvitationStatus user = do
|
||||
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
|
||||
@ -2064,7 +2089,8 @@ processChatCommand = \case
|
||||
void $ sendDirectContactMessage ct' (XInfo mergedProfile')
|
||||
when (directOrUsed ct') $ createSndFeatureItems user' ct ct'
|
||||
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
|
||||
| otherwise = do
|
||||
assertDirectAllowed user MDSnd ct XInfo_
|
||||
@ -2595,8 +2621,8 @@ acceptContactRequestAsync user UserContactRequest {agentInvitationId = AgentInvI
|
||||
let profileToSend = profileToSendOnAccept user incognitoProfile
|
||||
(cmdId, acId) <- agentAcceptContactAsync user True invId (XInfo profileToSend) subMode
|
||||
withStore' $ \db -> do
|
||||
ct@Contact {activeConn = Connection {connId}} <- createAcceptedContact db user acId (fromJVersionRange cReqChatVRange) cName profileId p userContactLinkId xContactId incognitoProfile subMode
|
||||
setCommandConnId db user cmdId connId
|
||||
ct@Contact {activeConn} <- createAcceptedContact db user acId (fromJVersionRange cReqChatVRange) cName profileId p userContactLinkId xContactId incognitoProfile subMode
|
||||
forM_ activeConn $ \Connection {connId} -> setCommandConnId db user cmdId connId
|
||||
pure ct
|
||||
|
||||
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 = do
|
||||
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)
|
||||
getUserContactLinkConns :: m ([ConnId], Map ConnId UserContact)
|
||||
getUserContactLinkConns = do
|
||||
@ -2758,9 +2784,10 @@ subscribeUserConnections onlyNeeded agentBatchSubscribe user@User {userId} = do
|
||||
toView $ CRNetworkStatuses (Just user) $ map (uncurry ConnNetworkStatus) statuses
|
||||
where
|
||||
addStatus :: ConnId -> Contact -> [(AgentConnId, NetworkStatus)] -> [(AgentConnId, NetworkStatus)]
|
||||
addStatus connId ct =
|
||||
let ns = (contactAgentConnId ct, netStatus $ resultErr connId rs)
|
||||
in (ns :)
|
||||
addStatus _ Contact {activeConn = Nothing} nss = nss
|
||||
addStatus connId Contact {activeConn = Just Connection {agentConnId}} nss =
|
||||
let ns = (agentConnId, netStatus $ resultErr connId rs)
|
||||
in ns : nss
|
||||
netStatus :: Maybe ChatError -> NetworkStatus
|
||||
netStatus = maybe NSConnected $ NSError . errorNetworkStatus
|
||||
errorNetworkStatus :: ChatError -> String
|
||||
@ -3203,7 +3230,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
cmdId <- createAckCmd conn
|
||||
withAckMessage agentConnId cmdId msgMeta $ do
|
||||
(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
|
||||
updateChatLock "directMessage" event
|
||||
case event of
|
||||
@ -3311,7 +3338,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
|
||||
(RSAgreed, Just _, _) -> do
|
||||
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'
|
||||
securityCodeChanged ct'
|
||||
_ -> ratchetSyncEventItem ct
|
||||
@ -3464,11 +3491,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
notifyMemberConnected gInfo m Nothing
|
||||
let connectedIncognito = memberIncognito membership
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingMemberContact m connectedIncognito
|
||||
Just ct@Contact {activeConn = Connection {connStatus}} ->
|
||||
when (connStatus == ConnReady) $ do
|
||||
notifyMemberConnected gInfo m $ Just ct
|
||||
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
|
||||
Just ct@Contact {activeConn} ->
|
||||
forM_ activeConn $ \Connection {connStatus} ->
|
||||
when (connStatus == ConnReady) $ do
|
||||
notifyMemberConnected gInfo m $ Just ct
|
||||
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
cmdId <- createAckCmd conn
|
||||
withAckMessage agentConnId cmdId msgMeta $ do
|
||||
@ -4279,7 +4307,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> do
|
||||
event <- withStore $ \db -> do
|
||||
ci' <- updateDirectCIFileStatus db user fileId $ CIFSSndTransfer 0 1
|
||||
sft <- liftIO $ createSndDirectInlineFT db ct ft
|
||||
sft <- createSndDirectInlineFT db ct ft
|
||||
pure $ CRSndFileStart user ci' sft
|
||||
toView event
|
||||
ifM
|
||||
@ -4395,30 +4423,31 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
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
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
|
||||
if sameGroupLinkId groupLinkId groupLinkId'
|
||||
then do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt memberId
|
||||
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
setViaGroupLinkHash db groupId connId
|
||||
createMemberConnectionAsync db user hostId connIds (fromJVersionRange peerChatVRange) subMode
|
||||
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
||||
else do
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
|
||||
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
|
||||
forM_ activeConn $ \Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
||||
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = membership@GroupMember {groupMemberId, memberId}}, hostId) <- withStore $ \db -> createGroupInvitation db user ct inv customUserProfileId
|
||||
if sameGroupLinkId groupLinkId groupLinkId'
|
||||
then do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
dm <- directMessage $ XGrpAcpt memberId
|
||||
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
|
||||
withStore' $ \db -> do
|
||||
setViaGroupLinkHash db groupId connId
|
||||
createMemberConnectionAsync db user hostId connIds (fromJVersionRange peerChatVRange) subMode
|
||||
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
||||
else do
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content
|
||||
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
|
||||
where
|
||||
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
|
||||
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'
|
||||
deleteAgentConnectionsAsync user $ map aConnId contactConns
|
||||
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)
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct'') ci)
|
||||
toView $ CRContactDeletedByContact user ct''
|
||||
@ -4951,20 +4981,21 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
Nothing -> createNewContact subMode
|
||||
Just mContactId -> do
|
||||
mCt <- withStore $ \db -> getContact db user mContactId
|
||||
let Contact {activeConn = Connection {connId}, contactGrpInvSent} = mCt
|
||||
if contactGrpInvSent
|
||||
then do
|
||||
ownConnReq <- withStore $ \db -> getConnReqInv db connId
|
||||
-- in case both members sent x.grp.direct.inv before receiving other's for processing,
|
||||
-- only the one who received greater connReq joins, the other creates items and waits for confirmation
|
||||
if strEncode connReq > strEncode ownConnReq
|
||||
then joinExistingContact subMode mCt
|
||||
else createItems mCt m
|
||||
else joinExistingContact subMode mCt
|
||||
let Contact {activeConn, contactGrpInvSent} = mCt
|
||||
forM_ activeConn $ \Connection {connId} ->
|
||||
if contactGrpInvSent
|
||||
then do
|
||||
ownConnReq <- withStore $ \db -> getConnReqInv db connId
|
||||
-- in case both members sent x.grp.direct.inv before receiving other's for processing,
|
||||
-- only the one who received greater connReq joins, the other creates items and waits for confirmation
|
||||
if strEncode connReq > strEncode ownConnReq
|
||||
then joinExistingContact subMode mCt
|
||||
else createItems mCt m
|
||||
else joinExistingContact subMode mCt
|
||||
where
|
||||
joinExistingContact subMode mCt = do
|
||||
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
|
||||
securityCodeChanged mCt'
|
||||
createNewContact subMode = do
|
||||
@ -5054,7 +5085,7 @@ parseFileDescription =
|
||||
sendDirectFileInline :: ChatMonad m => Contact -> FileTransferMeta -> SharedMsgId -> m ()
|
||||
sendDirectFileInline ct ft sharedMsgId = do
|
||||
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 m@GroupMember {groupId} conn ft sharedMsgId = do
|
||||
@ -5247,7 +5278,8 @@ deleteOrUpdateMemberRecord user@User {userId} member =
|
||||
Nothing -> deleteGroupMember db user member
|
||||
|
||||
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
|
||||
| contactStatus /= CSActive = throwChatError $ CEContactNotActive ct
|
||||
| connDisabled conn = throwChatError $ CEContactDisabled ct
|
||||
|
||||
@ -436,7 +436,7 @@ data ChatResponse
|
||||
| CRServerTestResult {user :: User, testServer :: AProtoServerWithAuth, testFailure :: Maybe ProtocolTestFailure}
|
||||
| CRChatItemTTL {user :: User, chatItemTTL :: Maybe Int64}
|
||||
| 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}
|
||||
| CRGroupMemberInfo {user :: User, groupInfo :: GroupInfo, member :: GroupMember, connectionStats_ :: Maybe ConnectionStats}
|
||||
| CRContactSwitchStarted {user :: User, contact :: Contact, connectionStats :: ConnectionStats}
|
||||
@ -1064,7 +1064,8 @@ chatModifyVar f newValue = asks f >>= atomically . (`modifyTVar'` newValue)
|
||||
{-# INLINE chatModifyVar #-}
|
||||
|
||||
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 = tryAllErrors mkChatError
|
||||
|
||||
@ -82,7 +82,7 @@ instance ToJSON ConnectionEntity where
|
||||
|
||||
updateEntityConnStatus :: ConnectionEntity -> ConnStatus -> ConnectionEntity
|
||||
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'}
|
||||
SndFileConnection c ft -> SndFileConnection (st c) ft
|
||||
RcvFileConnection c ft -> RcvFileConnection (st c) ft
|
||||
|
||||
@ -81,10 +81,11 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
|]
|
||||
(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' 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}
|
||||
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}
|
||||
toContact' _ _ _ = Left $ SEInternalError "referenced contact not found"
|
||||
getGroupAndMember_ :: Int64 -> Connection -> ExceptT StoreError IO (GroupInfo, GroupMember)
|
||||
|
||||
@ -194,13 +194,13 @@ createIncognitoProfile db User {userId} p = do
|
||||
createIncognitoProfile_ db userId createdAt p
|
||||
|
||||
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
|
||||
(localDisplayName, contactId, profileId) <- createContact_ db userId connId p localAlias Nothing createdAt (Just createdAt)
|
||||
let profile = toLocalProfile profileId p localAlias
|
||||
userPreferences = emptyChatPrefs
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
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}
|
||||
mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
|
||||
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 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)
|
||||
|
||||
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)
|
||||
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
|
||||
@ -229,16 +229,20 @@ deleteContact db user@User {userId} Contact {contactId, localDisplayName, active
|
||||
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 "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
|
||||
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)
|
||||
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 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 User {userId} Contact {contactId} = do
|
||||
@ -307,19 +311,19 @@ updateContactProfile db user@User {userId} c p'
|
||||
updateContact_ db userId contactId localDisplayName ldn currentTs
|
||||
pure $ Right c {localDisplayName = ldn, profile, mergedPreferences}
|
||||
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 = 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 user@User {userId} c@Contact {contactId, activeConn} userPreferences = do
|
||||
updateContactUserPreferences db user@User {userId} c@Contact {contactId} userPreferences = do
|
||||
updatedAt <- getCurrentTime
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE contacts SET user_preferences = ?, updated_at = ? WHERE user_id = ? AND contact_id = ?"
|
||||
(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}
|
||||
|
||||
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 user@User {userId} = do
|
||||
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 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 (?,?,?,?,?,?,?,?,?)"
|
||||
(userId, localDisplayName, profileId, True, userPreferences, createdAt, createdAt, createdAt, xContactId)
|
||||
contactId <- insertedRowId db
|
||||
activeConn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito activeConn
|
||||
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}
|
||||
conn <- createConnection_ db userId ConnContact (Just contactId) agentConnId cReqChatVRange Nothing (Just userContactLinkId) customUserProfileId 0 createdAt subMode
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito conn
|
||||
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 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 user@User {userId} contactId deleted =
|
||||
ExceptT . fmap join . firstRow (toContactOrError user) (SEContactNotFound contactId) $
|
||||
ExceptT . firstRow (toContact user) (SEContactNotFound contactId) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
|
||||
@ -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 (?,?,?,?,?,?)"
|
||||
(fileId, FSAccepted, connId, groupMemberId, currentTs, currentTs)
|
||||
|
||||
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> IO SndFileTransfer
|
||||
createSndDirectInlineFT db Contact {localDisplayName = n, activeConn = Connection {connId, agentConnId}} FileTransferMeta {fileId, fileName, filePath, fileSize, chunkSize, fileInline} = do
|
||||
createSndDirectInlineFT :: DB.Connection -> Contact -> FileTransferMeta -> ExceptT StoreError IO SndFileTransfer
|
||||
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
|
||||
let fileStatus = FSConnected
|
||||
fileInline' = Just $ fromMaybe IFMOffer fileInline
|
||||
@ -229,8 +230,9 @@ createSndGroupInlineFT db GroupMember {groupMemberId, localDisplayName = n} Conn
|
||||
(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'}
|
||||
|
||||
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> IO ()
|
||||
updateSndDirectFTDelivery db Contact {activeConn = Connection {connId}} FileTransferMeta {fileId} msgDeliveryId =
|
||||
updateSndDirectFTDelivery :: DB.Connection -> Contact -> FileTransferMeta -> Int64 -> ExceptT StoreError IO ()
|
||||
updateSndDirectFTDelivery _ Contact {localDisplayName, activeConn = Nothing} _ _ = throwError $ SEContactNotReady localDisplayName
|
||||
updateSndDirectFTDelivery db Contact {activeConn = Just Connection {connId}} FileTransferMeta {fileId} msgDeliveryId = liftIO $
|
||||
DB.execute
|
||||
db
|
||||
"UPDATE snd_files SET last_inline_msg_delivery_id = ? WHERE connection_id = ? AND file_id = ? AND file_inline IS NOT NULL"
|
||||
|
||||
@ -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
|
||||
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
|
||||
Nothing -> createGroupInvitation_
|
||||
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)
|
||||
|
||||
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
|
||||
createdAt <- liftIO getCurrentTime
|
||||
member@GroupMember {groupMemberId} <- createMember_ (MemberId memId) createdAt
|
||||
@ -1725,15 +1727,15 @@ createMemberContact
|
||||
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}
|
||||
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 user contactId = do
|
||||
ct <- getContact db user contactId
|
||||
let Contact {contactGroupMemberId, activeConn = Connection {connId}} = ct
|
||||
cReq <- getConnReqInv db connId
|
||||
case contactGroupMemberId of
|
||||
Just groupMemberId -> do
|
||||
let Contact {contactGroupMemberId, activeConn} = ct
|
||||
case (activeConn, contactGroupMemberId) of
|
||||
(Just Connection {connId}, Just groupMemberId) -> do
|
||||
cReq <- getConnReqInv db connId
|
||||
m@GroupMember {groupId} <- getGroupMemberById db user groupMemberId
|
||||
g <- getGroupInfo db user groupId
|
||||
pure (g, m, ct, cReq)
|
||||
@ -1762,7 +1764,7 @@ createMemberContactInvited
|
||||
contactId <- createContactUpdateMember currentTs userPreferences
|
||||
ctConn <- createMemberContactConn_ db user connIds gInfo mConn contactId subMode
|
||||
let mergedPreferences = contactUserPreferences user userPreferences preferences $ connIncognito ctConn
|
||||
mCt' = Contact {contactId, localDisplayName = memberLDN, profile = memberProfile, activeConn = 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}
|
||||
pure (mCt', m')
|
||||
where
|
||||
@ -1786,13 +1788,14 @@ createMemberContactInvited
|
||||
(contactId, currentTs, groupMemberId)
|
||||
pure contactId
|
||||
|
||||
updateMemberContactInvited :: DB.Connection -> User -> (CommandId, ConnId) -> GroupInfo -> Connection -> Contact -> SubscriptionMode -> IO Contact
|
||||
updateMemberContactInvited db user connIds gInfo mConn ct@Contact {contactId, activeConn = oldContactConn} subMode = do
|
||||
updateMemberContactInvited :: DB.Connection -> User -> (CommandId, ConnId) -> GroupInfo -> Connection -> Contact -> SubscriptionMode -> ExceptT StoreError IO Contact
|
||||
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
|
||||
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'' <- resetMemberContactFields db ct'
|
||||
pure (ct'' :: Contact) {activeConn}
|
||||
pure (ct'' :: Contact) {activeConn = Just activeConn'}
|
||||
|
||||
resetMemberContactFields :: DB.Connection -> Contact -> IO Contact
|
||||
resetMemberContactFields db ct@Contact {contactId} = do
|
||||
|
||||
@ -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
|
||||
FROM contacts ct
|
||||
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 (
|
||||
SELECT contact_id, MAX(chat_item_id) AS MaxId
|
||||
FROM chat_items
|
||||
@ -514,25 +514,31 @@ getDirectChatPreviews_ db user@User {userId} = do
|
||||
) 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
|
||||
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 c.connection_id = (
|
||||
SELECT cc_connection_id FROM (
|
||||
SELECT
|
||||
cc.connection_id AS cc_connection_id,
|
||||
cc.created_at AS cc_created_at,
|
||||
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
|
||||
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
|
||||
AND (
|
||||
(
|
||||
((c.conn_level = 0 AND c.via_group_link = 0) OR ct.contact_used = 1)
|
||||
AND c.connection_id = (
|
||||
SELECT cc_connection_id FROM (
|
||||
SELECT
|
||||
cc.connection_id AS cc_connection_id,
|
||||
cc.created_at AS cc_created_at,
|
||||
(CASE WHEN cc.conn_status = ? OR cc.conn_status = ? THEN 1 ELSE 0 END) AS cc_conn_status_ord
|
||||
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
|
||||
|]
|
||||
(CISRcvNew, userId, ConnReady, ConnSndReady)
|
||||
where
|
||||
toDirectChatPreview :: UTCTime -> ContactRow :. ConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
||||
toDirectChatPreview :: UTCTime -> ContactRow :. MaybeConnectionRow :. ChatStatsRow :. MaybeChatItemRow :. QuoteRow -> AChat
|
||||
toDirectChatPreview currentTs (contactRow :. connRow :. statsRow :. ciRow_) =
|
||||
let contact = toContact user $ contactRow :. connRow
|
||||
ci_ = toDirectChatItemList currentTs ciRow_
|
||||
|
||||
@ -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)
|
||||
|
||||
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) =
|
||||
let profile = LocalProfile {profileId, displayName, fullName, image, contactLink, preferences, localAlias}
|
||||
activeConn = toConnection connRow
|
||||
activeConn = toMaybeConnection connRow
|
||||
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}
|
||||
|
||||
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 userId profileId =
|
||||
ExceptT . firstRow toProfile (SEProfileNotFound profileId) $
|
||||
|
||||
@ -170,7 +170,7 @@ data Contact = Contact
|
||||
{ contactId :: ContactId,
|
||||
localDisplayName :: ContactName,
|
||||
profile :: LocalProfile,
|
||||
activeConn :: Connection,
|
||||
activeConn :: Maybe Connection,
|
||||
viaGroup :: Maybe Int64,
|
||||
contactUsed :: Bool,
|
||||
contactStatus :: ContactStatus,
|
||||
@ -189,32 +189,31 @@ instance ToJSON Contact where
|
||||
toJSON = J.genericToJSON J.defaultOptions {J.omitNothingFields = True}
|
||||
toEncoding = J.genericToEncoding J.defaultOptions {J.omitNothingFields = True}
|
||||
|
||||
contactConn :: Contact -> Connection
|
||||
contactConn :: Contact -> Maybe Connection
|
||||
contactConn Contact {activeConn} = activeConn
|
||||
|
||||
contactAgentConnId :: Contact -> AgentConnId
|
||||
contactAgentConnId Contact {activeConn = Connection {agentConnId}} = agentConnId
|
||||
|
||||
contactConnId :: Contact -> ConnId
|
||||
contactConnId = aConnId . contactConn
|
||||
contactConnId :: Contact -> Maybe ConnId
|
||||
contactConnId c = aConnId <$> contactConn c
|
||||
|
||||
type IncognitoEnabled = Bool
|
||||
|
||||
contactConnIncognito :: Contact -> IncognitoEnabled
|
||||
contactConnIncognito = connIncognito . contactConn
|
||||
contactConnIncognito = maybe False connIncognito . contactConn
|
||||
|
||||
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 ct@Contact {contactUsed} =
|
||||
contactDirect ct || contactUsed
|
||||
|
||||
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 {activeConn} = connReady activeConn
|
||||
contactReady Contact {activeConn} = maybe False connReady activeConn
|
||||
|
||||
contactActive :: Contact -> Bool
|
||||
contactActive Contact {contactStatus} = contactStatus == CSActive
|
||||
@ -223,7 +222,7 @@ contactDeleted :: Contact -> Bool
|
||||
contactDeleted Contact {contactStatus} = contactStatus == CSDeleted
|
||||
|
||||
contactSecurityCode :: Contact -> Maybe SecurityCode
|
||||
contactSecurityCode Contact {activeConn} = connectionCode activeConn
|
||||
contactSecurityCode Contact {activeConn} = connectionCode =<< activeConn
|
||||
|
||||
data ContactStatus
|
||||
= CSActive
|
||||
|
||||
@ -137,9 +137,11 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||
CRGroupsList u gs -> ttyUser u $ viewGroupsList gs
|
||||
CRSentGroupInvitation u g c _ ->
|
||||
ttyUser u $
|
||||
if viaGroupLink . contactConn $ c
|
||||
then [ttyContact' c <> " invited to group " <> ttyGroup' g <> " via your group link"]
|
||||
else ["invitation to join the group " <> ttyGroup' g <> " sent to " <> ttyContact' c]
|
||||
case contactConn c of
|
||||
Just Connection {viaGroupLink}
|
||||
| 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
|
||||
CRFileTransferStatusXFTP u ci -> ttyUser u $ viewFileTransferStatusXFTP ci
|
||||
CRUserProfile u p -> ttyUser u $ viewUserProfile p
|
||||
@ -325,7 +327,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||
testViewChats chats = [sShow $ map toChatView chats]
|
||||
where
|
||||
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 (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)
|
||||
@ -1038,10 +1040,10 @@ viewNetworkConfig NetworkConfig {socksProxy, tcpTimeout} =
|
||||
"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 =
|
||||
["contact ID: " <> sShow contactId]
|
||||
<> viewConnectionStats stats
|
||||
<> maybe [] viewConnectionStats stats
|
||||
<> maybe [] (\l -> ["contact address: " <> (plain . strEncode) (simplexChatContact l)]) contactLink
|
||||
<> maybe
|
||||
["you've shared main profile with this contact"]
|
||||
@ -1049,7 +1051,7 @@ viewContactInfo ct@Contact {contactId, profile = LocalProfile {localAlias, conta
|
||||
incognitoProfile
|
||||
<> ["alias: " <> plain localAlias | localAlias /= ""]
|
||||
<> [viewConnectionVerified (contactSecurityCode ct)]
|
||||
<> [viewPeerChatVRange (peerChatVRange activeConn)]
|
||||
<> maybe [] (\ac -> [viewPeerChatVRange (peerChatVRange ac)]) activeConn
|
||||
|
||||
viewGroupInfo :: GroupInfo -> GroupSummary -> [StyledString]
|
||||
viewGroupInfo GroupInfo {groupId} s =
|
||||
|
||||
Loading…
Reference in New Issue
Block a user