mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-05-10 21:37:09 +00:00
Merge branch 'master' into master-android
This commit is contained in:
spaced4ndy
+159
-90
@@ -69,6 +69,7 @@ import Simplex.Chat.Store.Shared
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Chat.Types.Util
|
||||
import Simplex.Chat.Util (encryptFile)
|
||||
import Simplex.FileTransfer.Client.Main (maxFileSize)
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
import Simplex.FileTransfer.Description (ValidFileDescription, gb, kb, mb)
|
||||
@@ -1462,13 +1463,13 @@ processChatCommand = \case
|
||||
-- TODO for large groups: no need to load all members to determine if contact is a member
|
||||
(group, contact) <- withStore $ \db -> (,) <$> getGroup db user groupId <*> getContact db user contactId
|
||||
assertDirectAllowed user MDSnd contact XGrpInv_
|
||||
let Group gInfo@GroupInfo {membership} members = group
|
||||
let Group gInfo members = group
|
||||
Contact {localDisplayName = cName} = contact
|
||||
assertUserGroupRole gInfo $ max GRAdmin memRole
|
||||
-- [incognito] forbid to invite contact to whom user is connected incognito
|
||||
when (contactConnIncognito contact) $ throwChatError CEContactIncognitoCantInvite
|
||||
-- [incognito] forbid to invite contacts if user joined the group using an incognito profile
|
||||
when (memberIncognito membership) $ throwChatError CEGroupIncognitoCantInvite
|
||||
when (incognitoMembership gInfo) $ throwChatError CEGroupIncognitoCantInvite
|
||||
let sendInvitation = sendGrpInvitation user contact gInfo
|
||||
case contactMember contact members of
|
||||
Nothing -> do
|
||||
@@ -1726,22 +1727,15 @@ processChatCommand = \case
|
||||
ft' <- if encrypted then encryptLocalFile ft else pure ft
|
||||
receiveFile' user ft' rcvInline_ filePath_
|
||||
where
|
||||
encryptLocalFile ft@RcvFileTransfer {xftpRcvFile} = case xftpRcvFile of
|
||||
Nothing -> throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||
Just f -> do
|
||||
cfArgs <- liftIO $ CF.randomArgs
|
||||
withStore' $ \db -> setFileCryptoArgs db fileId cfArgs
|
||||
pure ft {xftpRcvFile = Just ((f :: XFTPRcvFile) {cryptoArgs = Just cfArgs})}
|
||||
encryptLocalFile ft = do
|
||||
cfArgs <- liftIO $ CF.randomArgs
|
||||
withStore' $ \db -> setFileCryptoArgs db fileId cfArgs
|
||||
pure (ft :: RcvFileTransfer) {cryptoArgs = Just cfArgs}
|
||||
SetFileToReceive fileId encrypted -> withUser $ \_ -> do
|
||||
withChatLock "setFileToReceive" . procCmd $ do
|
||||
cfArgs <- if encrypted then fileCryptoArgs else pure Nothing
|
||||
cfArgs <- if encrypted then Just <$> liftIO CF.randomArgs else pure Nothing
|
||||
withStore' $ \db -> setRcvFileToReceive db fileId cfArgs
|
||||
ok_
|
||||
where
|
||||
fileCryptoArgs = do
|
||||
(_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId)
|
||||
unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP"
|
||||
liftIO $ Just <$> CF.randomArgs
|
||||
CancelFile fileId -> withUser $ \user@User {userId} ->
|
||||
withChatLock "cancelFile" . procCmd $
|
||||
withStore (\db -> getFileTransfer db user fileId) >>= \case
|
||||
@@ -2311,7 +2305,7 @@ receiveFile' user ft rcvInline_ filePath_ = do
|
||||
e -> throwError e
|
||||
|
||||
acceptFileReceive :: forall m. ChatMonad m => User -> RcvFileTransfer -> Maybe Bool -> Maybe FilePath -> m AChatItem
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId} rcvInline_ filePath_ = do
|
||||
acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileInvitation = FileInvitation {fileName = fName, fileConnReq, fileInline, fileSize}, fileStatus, grpMemberId, cryptoArgs} rcvInline_ filePath_ = do
|
||||
unless (fileStatus == RFSNew) $ case fileStatus of
|
||||
RFSCancelled _ -> throwChatError $ CEFileCancelled fName
|
||||
_ -> throwChatError $ CEFileAlreadyReceiving fName
|
||||
@@ -2324,7 +2318,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI
|
||||
filePath <- getRcvFilePath fileId filePath_ fName True
|
||||
withStoreCtx (Just "acceptFileReceive, acceptRcvFileTransfer") $ \db -> acceptRcvFileTransfer db user fileId connIds ConnJoined filePath subMode
|
||||
-- XFTP
|
||||
(Just XFTPRcvFile {cryptoArgs}, _) -> do
|
||||
(Just XFTPRcvFile {}, _) -> do
|
||||
filePath <- getRcvFilePath fileId filePath_ fName False
|
||||
(ci, rfd) <- withStoreCtx (Just "acceptFileReceive, xftpAcceptRcvFT ...") $ \db -> do
|
||||
-- marking file as accepted and reading description in the same transaction
|
||||
@@ -2398,7 +2392,7 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
|
||||
asks filesFolder >>= readTVarIO >>= \case
|
||||
Nothing -> do
|
||||
dir <- (`combine` "Downloads") <$> getHomeDirectory
|
||||
ifM (doesDirectoryExist dir) (pure dir) getTemporaryDirectory
|
||||
ifM (doesDirectoryExist dir) (pure dir) getChatTempDirectory
|
||||
>>= (`uniqueCombine` fn)
|
||||
>>= createEmptyFile
|
||||
Just filesFolder ->
|
||||
@@ -2426,14 +2420,18 @@ getRcvFilePath fileId fPath_ fn keepHandle = case fPath_ of
|
||||
pure fPath
|
||||
getTmpHandle :: FilePath -> m Handle
|
||||
getTmpHandle fPath = openFile fPath AppendMode `catchThrow` (ChatError . CEFileInternal . show)
|
||||
uniqueCombine :: FilePath -> String -> m FilePath
|
||||
uniqueCombine filePath fileName = tryCombine (0 :: Int)
|
||||
where
|
||||
tryCombine n =
|
||||
let (name, ext) = splitExtensions fileName
|
||||
suffix = if n == 0 then "" else "_" <> show n
|
||||
f = filePath `combine` (name <> suffix <> ext)
|
||||
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
|
||||
|
||||
uniqueCombine :: MonadIO m => FilePath -> String -> m FilePath
|
||||
uniqueCombine filePath fileName = tryCombine (0 :: Int)
|
||||
where
|
||||
tryCombine n =
|
||||
let (name, ext) = splitExtensions fileName
|
||||
suffix = if n == 0 then "" else "_" <> show n
|
||||
f = filePath `combine` (name <> suffix <> ext)
|
||||
in ifM (doesFileExist f) (tryCombine $ n + 1) (pure f)
|
||||
|
||||
getChatTempDirectory :: ChatMonad m => m FilePath
|
||||
getChatTempDirectory = chatReadVar tempDirectory >>= maybe getTemporaryDirectory pure
|
||||
|
||||
acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> Maybe IncognitoProfile -> m Contact
|
||||
acceptContactRequest user UserContactRequest {agentInvitationId = AgentInvId invId, cReqChatVRange, localDisplayName = cName, profileId, profile = cp, userContactLinkId, xContactId} incognitoProfile = do
|
||||
@@ -3029,7 +3027,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct' sharedMsgId fileConnReq_ fName msgMeta
|
||||
XInfo p -> xInfo ct' p
|
||||
XGrpInv gInv -> processGroupInvitation ct' gInv msg msgMeta
|
||||
XInfoProbe probe -> xInfoProbe ct' probe
|
||||
XInfoProbe probe -> xInfoProbe (CGMContact ct') probe
|
||||
XInfoProbeCheck probeHash -> xInfoProbeCheck ct' probeHash
|
||||
XInfoProbeOk probe -> xInfoProbeOk ct' probe
|
||||
XCallInv callId invitation -> xCallInv ct' callId invitation msg msgMeta
|
||||
@@ -3054,10 +3052,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- TODO update member profile
|
||||
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
||||
allowAgentConnectionAsync user conn' confId XOk
|
||||
XOk -> do
|
||||
allowAgentConnectionAsync user conn' confId XOk
|
||||
void $ withStore' $ \db -> resetMemberContactFields db ct
|
||||
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.ok"
|
||||
XInfo profile -> do
|
||||
ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct)
|
||||
-- [incognito] send incognito profile
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
||||
let p = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct')
|
||||
allowAgentConnectionAsync user conn' confId $ XInfo p
|
||||
void $ withStore' $ \db -> resetMemberContactFields db ct'
|
||||
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
|
||||
INFO connInfo -> do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
||||
_conn' <- updatePeerChatVRange conn chatVRange
|
||||
@@ -3066,9 +3068,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- TODO check member ID
|
||||
-- TODO update member profile
|
||||
pure ()
|
||||
XInfo _profile -> do
|
||||
-- TODO update contact profile
|
||||
pure ()
|
||||
XInfo profile ->
|
||||
void $ processContactProfileUpdate ct profile False
|
||||
XOk -> pure ()
|
||||
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
|
||||
CON ->
|
||||
@@ -3095,10 +3096,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
||||
withStore $ \db -> createNewContactMemberAsync db gVar user groupId ct gLinkMemRole groupConnIds (fromJVersionRange peerChatVRange) subMode
|
||||
_ -> pure ()
|
||||
Just (gInfo@GroupInfo {membership}, m@GroupMember {activeConn}) ->
|
||||
Just (gInfo, m@GroupMember {activeConn}) ->
|
||||
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
||||
notifyMemberConnected gInfo m $ Just ct
|
||||
let connectedIncognito = contactConnIncognito ct || memberIncognito membership
|
||||
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct connectedIncognito
|
||||
SENT msgId -> do
|
||||
sentMsgDeliveryEvent conn msgId
|
||||
@@ -3161,7 +3162,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of
|
||||
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
||||
CFCreateConnGrpMemInv
|
||||
| isCompatibleRange (fromJVersionRange $ peerChatVRange conn) groupNoDirectVRange -> sendWithDirectCReq -- sendWithoutDirectCReq
|
||||
| isCompatibleRange (fromJVersionRange $ peerChatVRange conn) groupNoDirectVRange -> sendWithoutDirectCReq
|
||||
| otherwise -> sendWithDirectCReq
|
||||
where
|
||||
sendWithoutDirectCReq = do
|
||||
@@ -3262,16 +3263,16 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
void $ sendDirectMessage conn (XGrpMemIntro $ memberInfo (reMember intro)) (GroupId groupId)
|
||||
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
|
||||
_ -> do
|
||||
-- TODO send probe and decide whether to use existing contact connection or the new contact connection
|
||||
-- TODO notify member who forwarded introduction - question - where it is stored? There is via_contact but probably there should be via_member in group_members table
|
||||
withStore' (\db -> getViaGroupContact db user m) >>= \case
|
||||
Nothing -> do
|
||||
notifyMemberConnected gInfo m Nothing
|
||||
messageWarning "connected member does not have contact"
|
||||
let connectedIncognito = memberIncognito membership
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingMemberContact gInfo m connectedIncognito
|
||||
Just ct@Contact {activeConn = Connection {connStatus}} ->
|
||||
when (connStatus == ConnReady) $ do
|
||||
notifyMemberConnected gInfo m $ Just ct
|
||||
let connectedIncognito = contactConnIncognito ct || memberIncognito membership
|
||||
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
||||
when (memberCategory m == GCPreMember) $ probeMatchingContacts ct connectedIncognito
|
||||
MSG msgMeta _msgFlags msgBody -> do
|
||||
cmdId <- createAckCmd conn
|
||||
@@ -3300,6 +3301,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
XGrpDel -> xGrpDel gInfo m' msg msgMeta
|
||||
XGrpInfo p' -> xGrpInfo gInfo m' p' msg msgMeta
|
||||
XGrpDirectInv connReq mContent_ -> canSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg msgMeta
|
||||
XInfoProbe probe -> xInfoProbe (CGMGroupMember gInfo m') probe
|
||||
-- XInfoProbeCheck -- TODO merge members?
|
||||
-- XInfoProbeOk -- TODO merge members?
|
||||
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
|
||||
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
||||
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
||||
@@ -3501,12 +3505,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
RcvChunkOk ->
|
||||
if B.length chunk /= fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else ack $ appendFileChunk ft chunkNo chunk
|
||||
else ack $ appendFileChunk ft chunkNo chunk False
|
||||
RcvChunkFinal ->
|
||||
if B.length chunk > fromInteger chunkSize
|
||||
then badRcvFileChunk ft "incorrect chunk size"
|
||||
else do
|
||||
appendFileChunk ft chunkNo chunk
|
||||
appendFileChunk ft chunkNo chunk True
|
||||
ci <- withStore $ \db -> do
|
||||
liftIO $ do
|
||||
updateRcvFileStatus db fileId FSComplete
|
||||
@@ -3514,7 +3518,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
deleteRcvFileChunks db ft
|
||||
getChatItemByFileId db user fileId
|
||||
toView $ CRRcvFileComplete user ci
|
||||
closeFileHandle fileId rcvFiles
|
||||
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
|
||||
RcvChunkDuplicate -> ack $ pure ()
|
||||
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
|
||||
@@ -3556,8 +3559,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ct <- acceptContactRequestAsync user cReq incognitoProfile
|
||||
toView $ CRAcceptingContactRequest user ct
|
||||
Just groupId -> do
|
||||
gInfo@GroupInfo {membership = membership@GroupMember {memberProfile}} <- withStore $ \db -> getGroupInfo db user groupId
|
||||
let profileMode = if memberIncognito membership then Just $ ExistingIncognito memberProfile else Nothing
|
||||
gInfo <- withStore $ \db -> getGroupInfo db user groupId
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
ct <- acceptContactRequestAsync user cReq profileMode
|
||||
toView $ CRAcceptingGroupJoinRequest user gInfo ct
|
||||
_ -> do
|
||||
@@ -3665,19 +3668,42 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
probeMatchingContacts :: Contact -> IncognitoEnabled -> m ()
|
||||
probeMatchingContacts ct connectedIncognito = do
|
||||
gVar <- asks idsDrg
|
||||
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId ct
|
||||
void . sendDirectContactMessage ct $ XInfoProbe probe
|
||||
if connectedIncognito
|
||||
then withStore' $ \db -> deleteSentProbe db userId probeId
|
||||
then sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
||||
else do
|
||||
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId (CGMContact ct)
|
||||
sendProbe probe
|
||||
cs <- withStore' $ \db -> getMatchingContacts db user ct
|
||||
let probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
|
||||
forM_ cs $ \c -> sendProbeHash c probeHash probeId `catchChatError` \_ -> pure ()
|
||||
sendProbeHashes cs probe probeId
|
||||
where
|
||||
sendProbeHash :: Contact -> ProbeHash -> Int64 -> m ()
|
||||
sendProbeHash c probeHash probeId = do
|
||||
sendProbe :: Probe -> m ()
|
||||
sendProbe probe = void . sendDirectContactMessage ct $ XInfoProbe probe
|
||||
|
||||
probeMatchingMemberContact :: GroupInfo -> GroupMember -> IncognitoEnabled -> m ()
|
||||
probeMatchingMemberContact _ GroupMember {activeConn = Nothing} _ = pure ()
|
||||
probeMatchingMemberContact g m@GroupMember {groupId, activeConn = Just conn} connectedIncognito = do
|
||||
gVar <- asks idsDrg
|
||||
if connectedIncognito
|
||||
then sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
||||
else do
|
||||
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ CGMGroupMember g m
|
||||
sendProbe probe
|
||||
cs <- withStore' $ \db -> getMatchingMemberContacts db user m
|
||||
sendProbeHashes cs probe probeId
|
||||
where
|
||||
sendProbe :: Probe -> m ()
|
||||
sendProbe probe = void $ sendDirectMessage conn (XInfoProbe probe) (GroupId groupId)
|
||||
|
||||
-- TODO currently we only send probe hashes to contacts
|
||||
sendProbeHashes :: [Contact] -> Probe -> Int64 -> m ()
|
||||
sendProbeHashes cs probe probeId =
|
||||
forM_ cs $ \c -> sendProbeHash c `catchChatError` \_ -> pure ()
|
||||
where
|
||||
probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
|
||||
sendProbeHash :: Contact -> m ()
|
||||
sendProbeHash c = do
|
||||
void . sendDirectContactMessage c $ XInfoProbeCheck probeHash
|
||||
withStore' $ \db -> createSentProbeHash db userId probeId c
|
||||
withStore' $ \db -> createSentProbeHash db userId probeId $ CGMContact c
|
||||
|
||||
messageWarning :: Text -> m ()
|
||||
messageWarning = toView . CRMessageError user "warning"
|
||||
@@ -3737,14 +3763,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
processFDMessage fileId fileDescr = do
|
||||
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
||||
unless (rcvFileCompleteOrCancelled ft) $ do
|
||||
(rfd, RcvFileTransfer {fileStatus, xftpRcvFile}) <- withStore $ \db -> do
|
||||
(rfd, RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do
|
||||
rfd <- appendRcvFD db userId fileId fileDescr
|
||||
-- reading second time in the same transaction as appending description
|
||||
-- to prevent race condition with accept
|
||||
ft' <- getRcvFileTransfer db user fileId
|
||||
pure (rfd, ft')
|
||||
case (fileStatus, xftpRcvFile) of
|
||||
(RFSAccepted _, Just XFTPRcvFile {cryptoArgs}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
(RFSAccepted _, Just XFTPRcvFile {}) -> receiveViaCompleteFD user fileId rfd cryptoArgs
|
||||
_ -> pure ()
|
||||
|
||||
cancelMessageFile :: Contact -> SharedMsgId -> MsgMeta -> m ()
|
||||
@@ -4201,15 +4227,22 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs)
|
||||
|
||||
xInfo :: Contact -> Profile -> m ()
|
||||
xInfo c@Contact {profile = p} p' = unless (fromLocalProfile p == p') $ do
|
||||
c' <- withStore $ \db ->
|
||||
if userTTL == rcvTTL
|
||||
then updateContactProfile db user c p'
|
||||
else do
|
||||
c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs'
|
||||
updateContactProfile db user c' p'
|
||||
when (directOrUsed c') $ createRcvFeatureItems user c c'
|
||||
toView $ CRContactUpdated user c c'
|
||||
xInfo c p' = void $ processContactProfileUpdate c p' True
|
||||
|
||||
processContactProfileUpdate :: Contact -> Profile -> Bool -> m Contact
|
||||
processContactProfileUpdate c@Contact {profile = p} p' createItems
|
||||
| fromLocalProfile p /= p' = do
|
||||
c' <- withStore $ \db ->
|
||||
if userTTL == rcvTTL
|
||||
then updateContactProfile db user c p'
|
||||
else do
|
||||
c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs'
|
||||
updateContactProfile db user c' p'
|
||||
when (directOrUsed c' && createItems) $ createRcvFeatureItems user c c'
|
||||
toView $ CRContactUpdated user c c'
|
||||
pure c'
|
||||
| otherwise =
|
||||
pure c
|
||||
where
|
||||
Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c
|
||||
userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs
|
||||
@@ -4238,35 +4271,48 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(_, param) = groupFeatureState p
|
||||
createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing
|
||||
|
||||
xInfoProbe :: Contact -> Probe -> m ()
|
||||
xInfoProbe c2 probe =
|
||||
xInfoProbe :: ContactOrGroupMember -> Probe -> m ()
|
||||
xInfoProbe cgm2 probe =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c2) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbe db user c2 probe
|
||||
forM_ r $ \c1 -> probeMatch c1 c2 probe
|
||||
unless (contactOrGroupMemberIncognito cgm2) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbe db user cgm2 probe
|
||||
forM_ r $ \case
|
||||
CGMContact c1 -> probeMatch c1 cgm2 probe
|
||||
CGMGroupMember _ _ -> messageWarning "xInfoProbe ignored: matched member (no probe hashes sent to members)"
|
||||
|
||||
-- TODO currently we send probe hashes only to contacts
|
||||
xInfoProbeCheck :: Contact -> ProbeHash -> m ()
|
||||
xInfoProbeCheck c1 probeHash =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c1) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db user c1 probeHash
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db user (CGMContact c1) probeHash
|
||||
forM_ r . uncurry $ probeMatch c1
|
||||
|
||||
probeMatch :: Contact -> Contact -> Probe -> m ()
|
||||
probeMatch c1@Contact {contactId = cId1, profile = p1} c2@Contact {contactId = cId2, profile = p2} probe =
|
||||
if profilesMatch (fromLocalProfile p1) (fromLocalProfile p2) && cId1 /= cId2
|
||||
then do
|
||||
void . sendDirectContactMessage c1 $ XInfoProbeOk probe
|
||||
mergeContacts c1 c2
|
||||
else messageWarning "probeMatch ignored: profiles don't match or same contact id"
|
||||
probeMatch :: Contact -> ContactOrGroupMember -> Probe -> m ()
|
||||
probeMatch c1@Contact {contactId = cId1, profile = p1} cgm2 probe =
|
||||
case cgm2 of
|
||||
CGMContact c2@Contact {contactId = cId2, profile = p2}
|
||||
| cId1 /= cId2 && profilesMatch p1 p2 -> do
|
||||
void . sendDirectContactMessage c1 $ XInfoProbeOk probe
|
||||
mergeContacts c1 c2
|
||||
| otherwise -> messageWarning "probeMatch ignored: profiles don't match or same contact id"
|
||||
CGMGroupMember g m2@GroupMember {memberProfile = p2, memberContactId}
|
||||
| isNothing memberContactId && profilesMatch p1 p2 -> do
|
||||
void . sendDirectContactMessage c1 $ XInfoProbeOk probe
|
||||
connectContactToMember c1 g m2
|
||||
| otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact"
|
||||
|
||||
-- TODO currently we send probe hashes only to contacts
|
||||
xInfoProbeOk :: Contact -> Probe -> m ()
|
||||
xInfoProbeOk c1@Contact {contactId = cId1} probe = do
|
||||
r <- withStore' $ \db -> matchSentProbe db user c1 probe
|
||||
forM_ r $ \c2@Contact {contactId = cId2} ->
|
||||
if cId1 /= cId2
|
||||
then mergeContacts c1 c2
|
||||
else messageWarning "xInfoProbeOk ignored: same contact id"
|
||||
xInfoProbeOk c1@Contact {contactId = cId1} probe =
|
||||
withStore' (\db -> matchSentProbe db user (CGMContact c1) probe) >>= \case
|
||||
Just (CGMContact c2@Contact {contactId = cId2})
|
||||
| cId1 /= cId2 -> mergeContacts c1 c2
|
||||
| otherwise -> messageWarning "xInfoProbeOk ignored: same contact id"
|
||||
Just (CGMGroupMember g m2@GroupMember {memberContactId})
|
||||
| isNothing memberContactId -> connectContactToMember c1 g m2
|
||||
| otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact"
|
||||
_ -> pure ()
|
||||
|
||||
-- to party accepting call
|
||||
xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
@@ -4378,6 +4424,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
withStore' $ \db -> mergeContactRecords db userId c1 c2
|
||||
toView $ CRContactsMerged user c1 c2
|
||||
|
||||
connectContactToMember :: Contact -> GroupInfo -> GroupMember -> m ()
|
||||
connectContactToMember c1 g m2 = do
|
||||
withStore' $ \db -> updateMemberContact db user c1 m2
|
||||
toView $ CRMemberContactConnected user c1 g m2
|
||||
|
||||
saveConnInfo :: Connection -> ConnInfo -> m Connection
|
||||
saveConnInfo activeConn connInfo = do
|
||||
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
|
||||
@@ -4404,7 +4455,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
|
||||
|
||||
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
|
||||
xGrpMemIntro gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
|
||||
xGrpMemIntro gInfo@GroupInfo {chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
@@ -4418,9 +4469,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
directConnIds <- case memberChatVRange of
|
||||
Nothing -> Just <$> createConn subMode
|
||||
Just mcvr
|
||||
| isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> Just <$> createConn subMode -- pure Nothing
|
||||
| isCompatibleRange (fromChatVRange mcvr) groupNoDirectVRange -> pure Nothing
|
||||
| otherwise -> Just <$> createConn subMode
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
where
|
||||
@@ -4464,7 +4515,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
|
||||
let customUserProfileId = if memberIncognito membership then Just (localProfileId $ memberProfile membership) else Nothing
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
|
||||
@@ -4589,7 +4640,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
(mCt', m') <- withStore' $ \db -> createMemberContactInvited db user connIds g m mConn subMode
|
||||
createItems mCt' m'
|
||||
joinConn subMode = do
|
||||
dm <- directMessage XOk
|
||||
-- [incognito] send membership incognito profile
|
||||
let p = userProfileToSend user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing
|
||||
dm <- directMessage $ XInfo p
|
||||
joinAgentConnectionAsync user True connReq dm subMode
|
||||
createItems mCt' m' = do
|
||||
checkIntegrityCreateItem (CDGroupRcv g m') msgMeta
|
||||
@@ -4733,8 +4786,8 @@ readFileChunk SndFileTransfer {fileId, filePath, chunkSize} chunkNo = do
|
||||
parseFileChunk :: ChatMonad m => ByteString -> m FileChunk
|
||||
parseFileChunk = liftEither . first (ChatError . CEFileRcvChunk) . smpDecode
|
||||
|
||||
appendFileChunk :: ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> m ()
|
||||
appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk =
|
||||
appendFileChunk :: forall m. ChatMonad m => RcvFileTransfer -> Integer -> ByteString -> Bool -> m ()
|
||||
appendFileChunk ft@RcvFileTransfer {fileId, fileInvitation, fileStatus, cryptoArgs} chunkNo chunk final =
|
||||
case fileStatus of
|
||||
RFSConnected RcvFileInfo {filePath} -> append_ filePath
|
||||
-- sometimes update of file transfer status to FSConnected
|
||||
@@ -4743,11 +4796,27 @@ appendFileChunk ft@RcvFileTransfer {fileId, fileStatus} chunkNo chunk =
|
||||
RFSCancelled _ -> pure ()
|
||||
_ -> throwChatError $ CEFileInternal "receiving file transfer not in progress"
|
||||
where
|
||||
append_ :: FilePath -> m ()
|
||||
append_ filePath = do
|
||||
fsFilePath <- toFSFilePath filePath
|
||||
h <- getFileHandle fileId fsFilePath rcvFiles AppendMode
|
||||
liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (ChatError . CEFileWrite filePath . show)
|
||||
liftIO (B.hPut h chunk >> hFlush h) `catchThrow` (fileErr . show)
|
||||
withStore' $ \db -> updatedRcvFileChunkStored db ft chunkNo
|
||||
when final $ do
|
||||
closeFileHandle fileId rcvFiles
|
||||
forM_ cryptoArgs $ \cfArgs -> do
|
||||
tmpFile <- getChatTempDirectory >>= (`uniqueCombine` fileName (fileInvitation :: FileInvitation))
|
||||
tryChatError (liftError encryptErr $ encryptFile fsFilePath tmpFile cfArgs) >>= \case
|
||||
Right () -> do
|
||||
removeFile fsFilePath `catchChatError` \_ -> pure ()
|
||||
renameFile tmpFile fsFilePath
|
||||
Left e -> do
|
||||
toView $ CRChatError Nothing e
|
||||
removeFile tmpFile `catchChatError` \_ -> pure ()
|
||||
withStore' (`removeFileCryptoArgs` fileId)
|
||||
where
|
||||
encryptErr e = fileErr $ e <> ", received file not encrypted"
|
||||
fileErr = ChatError . CEFileWrite filePath
|
||||
|
||||
getFileHandle :: ChatMonad m => Int64 -> FilePath -> (ChatController -> TVar (Map Int64 Handle)) -> IOMode -> m Handle
|
||||
getFileHandle fileId filePath files ioMode = do
|
||||
|
||||
Reference in New Issue
Block a user