mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2024-12-17 17:20:21 +01:00
core: incognito connections (#926)
This commit is contained in:
JRoberts
GitHub
+177
-97
@@ -31,13 +31,12 @@ import Data.Either (fromRight)
|
||||
import Data.Fixed (div')
|
||||
import Data.Functor (($>))
|
||||
import Data.Int (Int64)
|
||||
import Data.List (find, isSuffixOf, sortBy, sortOn)
|
||||
import Data.List (find, isSuffixOf, sortOn)
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import qualified Data.List.NonEmpty as L
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
|
||||
@@ -51,6 +50,7 @@ import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
||||
import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Store
|
||||
import Simplex.Chat.Types
|
||||
@@ -143,8 +143,9 @@ newChatController chatStore user cfg@ChatConfig {agentConfig = aCfg, tbqSize, de
|
||||
rcvFiles <- newTVarIO M.empty
|
||||
currentCalls <- atomically TM.empty
|
||||
filesFolder <- newTVarIO Nothing
|
||||
incognitoMode <- newTVarIO False
|
||||
chatStoreChanged <- newTVarIO False
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder}
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder}
|
||||
where
|
||||
resolveServers :: InitialAgentServers -> IO InitialAgentServers
|
||||
resolveServers ss@InitialAgentServers {smp = defaultSMPServers} = case nonEmpty smpServers of
|
||||
@@ -233,6 +234,10 @@ processChatCommand = \case
|
||||
ff <- asks filesFolder
|
||||
atomically . writeTVar ff $ Just filesFolder'
|
||||
pure CRCmdOk
|
||||
SetIncognito onOff -> do
|
||||
incognito <- asks incognitoMode
|
||||
atomically . writeTVar incognito $ onOff
|
||||
pure CRCmdOk
|
||||
APIExportArchive cfg -> checkChatStopped $ exportArchive cfg $> CRCmdOk
|
||||
APIImportArchive cfg -> checkChatStopped $ importArchive cfg >> setStoreChanged $> CRCmdOk
|
||||
APIDeleteStorage -> checkChatStopped $ deleteStorage >> setStoreChanged $> CRCmdOk
|
||||
@@ -254,16 +259,14 @@ processChatCommand = \case
|
||||
pure . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat ct) ci
|
||||
where
|
||||
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd))
|
||||
setupSndFileTransfer ct = case file_ of
|
||||
Nothing -> pure Nothing
|
||||
Just file -> do
|
||||
(fileSize, chSize) <- checkSndFile file
|
||||
(agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq}
|
||||
fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
pure $ Just (fileInvitation, ciFile)
|
||||
setupSndFileTransfer ct = forM file_ $ \file -> do
|
||||
(fileSize, chSize) <- checkSndFile file
|
||||
(agentConnId, fileConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Just fileConnReq}
|
||||
fileId <- withStore' $ \db -> createSndFileTransfer db userId ct file fileInvitation agentConnId chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
pure (fileInvitation, ciFile)
|
||||
prepareMsg :: Maybe FileInvitation -> m (MsgContainer, Maybe (CIQuote 'CTDirect))
|
||||
prepareMsg fileInvitation_ = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing)
|
||||
@@ -291,15 +294,13 @@ processChatCommand = \case
|
||||
pure . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
|
||||
where
|
||||
setupSndFileTransfer :: GroupInfo -> m (Maybe (FileInvitation, CIFile 'MDSnd))
|
||||
setupSndFileTransfer gInfo = case file_ of
|
||||
Nothing -> pure Nothing
|
||||
Just file -> do
|
||||
(fileSize, chSize) <- checkSndFile file
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing}
|
||||
fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
pure $ Just (fileInvitation, ciFile)
|
||||
setupSndFileTransfer gInfo = forM file_ $ \file -> do
|
||||
(fileSize, chSize) <- checkSndFile file
|
||||
let fileName = takeFileName file
|
||||
fileInvitation = FileInvitation {fileName, fileSize, fileConnReq = Nothing}
|
||||
fileId <- withStore' $ \db -> createSndGroupFileTransfer db userId gInfo file fileInvitation chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Just file, fileStatus = CIFSSndStored}
|
||||
pure (fileInvitation, ciFile)
|
||||
prepareMsg :: Maybe FileInvitation -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup))
|
||||
prepareMsg fileInvitation_ membership = case quotedItemId_ of
|
||||
Nothing -> pure (MCSimple (ExtMsgContent mc fileInvitation_), Nothing)
|
||||
@@ -597,11 +598,17 @@ processChatCommand = \case
|
||||
APISetNetworkConfig cfg -> withUser' $ \_ -> withAgent (`setNetworkConfig` cfg) $> CRCmdOk
|
||||
APIGetNetworkConfig -> CRNetworkConfig <$> withUser' (\_ -> withAgent getNetworkConfig)
|
||||
APIContactInfo contactId -> withUser $ \User {userId} -> do
|
||||
ct <- withStore $ \db -> getContact db userId contactId
|
||||
CRContactInfo ct <$> withAgent (`getConnectionServers` contactConnId ct)
|
||||
APIGroupMemberInfo gId gMemberId -> withUser $ \user -> do
|
||||
(g, m) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
CRGroupMemberInfo g m <$> mapM (withAgent . flip getConnectionServers) (memberConnId m)
|
||||
-- [incognito] print user's incognito profile for this contact
|
||||
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db userId contactId
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
connectionStats <- withAgent (`getConnectionServers` contactConnId ct)
|
||||
pure $ CRContactInfo ct connectionStats incognitoProfile
|
||||
APIGroupMemberInfo gId gMemberId -> withUser $ \user@User {userId} -> do
|
||||
-- [incognito] print group member main profile
|
||||
(g, m@GroupMember {memberContactProfileId}) <- withStore $ \db -> (,) <$> getGroupInfo db user gId <*> getGroupMember db user gId gMemberId
|
||||
mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing
|
||||
connectionStats <- mapM (withAgent . flip getConnectionServers) (memberConnId m)
|
||||
pure $ CRGroupMemberInfo g m connectionStats mainProfile
|
||||
ContactInfo cName -> withUser $ \User {userId} -> do
|
||||
contactId <- withStore $ \db -> getContactIdByName db userId cName
|
||||
processChatCommand $ APIContactInfo contactId
|
||||
@@ -611,20 +618,29 @@ processChatCommand = \case
|
||||
ChatHelp section -> pure $ CRChatHelp section
|
||||
Welcome -> withUser $ pure . CRWelcome
|
||||
AddContact -> withUser $ \User {userId} -> withChatLock . procCmd $ do
|
||||
-- [incognito] generate profile for connection
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
(connId, cReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
conn <- withStore' $ \db -> createDirectConnection db userId connId ConnNew
|
||||
conn <- withStore' $ \db -> createDirectConnection db userId connId ConnNew incognitoProfile
|
||||
toView $ CRNewContactConnection conn
|
||||
pure $ CRInvitation cReq
|
||||
Connect (Just (ACR SCMInvitation cReq)) -> withUser $ \User {userId, profile} -> withChatLock . procCmd $ do
|
||||
connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profile
|
||||
conn <- withStore' $ \db -> createDirectConnection db userId connId ConnJoined
|
||||
-- [incognito] generate profile to send
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile
|
||||
connId <- withAgent $ \a -> joinConnection a cReq . directMessage $ XInfo profileToSend
|
||||
conn <- withStore' $ \db -> createDirectConnection db userId connId ConnJoined incognitoProfile
|
||||
toView $ CRNewContactConnection conn
|
||||
pure CRSentConfirmation
|
||||
Connect (Just (ACR SCMContact cReq)) -> withUser $ \User {userId, profile} ->
|
||||
connectViaContact userId cReq profile
|
||||
-- [incognito] generate profile to send
|
||||
connectViaContact userId cReq $ fromLocalProfile profile
|
||||
Connect Nothing -> throwChatError CEInvalidConnReq
|
||||
ConnectSimplex -> withUser $ \User {userId, profile} ->
|
||||
connectViaContact userId adminContactReq profile
|
||||
-- [incognito] generate profile to send
|
||||
connectViaContact userId adminContactReq $ fromLocalProfile profile
|
||||
DeleteContact cName -> withUser $ \User {userId} -> do
|
||||
contactId <- withStore $ \db -> getContactIdByName db userId cName
|
||||
processChatCommand $ APIDeleteChat (ChatRef CTDirect contactId)
|
||||
@@ -686,29 +702,37 @@ processChatCommand = \case
|
||||
processChatCommand $ APIUpdateChatItem chatRef editedItemId mc
|
||||
NewGroup gProfile -> withUser $ \user -> do
|
||||
gVar <- asks idsDrg
|
||||
CRGroupCreated <$> withStore (\db -> createNewGroup db gVar user gProfile)
|
||||
-- [incognito] create membership with incognito profile
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
groupInfo <- withStore (\db -> createNewGroup db gVar user gProfile incognitoProfile)
|
||||
pure $ CRGroupCreated groupInfo incognitoProfile
|
||||
APIAddMember groupId contactId memRole -> withUser $ \user@User {userId} -> withChatLock $ do
|
||||
-- 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 userId contactId
|
||||
-- [incognito] forbid to invite contact to whom user is connected as incognito if user's membership is not incognito
|
||||
let Group gInfo@GroupInfo {localDisplayName, groupProfile, membership} members = group
|
||||
GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
||||
Contact {localDisplayName = cName} = contact
|
||||
when (contactConnIncognito contact && not (memberIncognito membership)) $ throwChatError CEGroupNotIncognitoCantInvite
|
||||
when (userRole < GRAdmin || userRole < memRole) $ throwChatError CEGroupUserRole
|
||||
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined gInfo)
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
let sendInvitation member@GroupMember {groupMemberId, memberId} cReq = do
|
||||
let groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile
|
||||
-- [incognito] if membership is incognito, send its incognito profile in GroupInvitation
|
||||
let incognitoProfile = if memberIncognito membership then Just (fromLocalProfile $ memberProfile membership) else Nothing
|
||||
groupInv = GroupInvitation (MemberIdRole userMemberId userRole) incognitoProfile (MemberIdRole memberId memRole) cReq groupProfile
|
||||
msg <- sendDirectContactMessage contact $ XGrpInv groupInv
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending, invitedIncognito = Just $ memberIncognito membership}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd contact) msg content Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDSnd (DirectChat contact) ci
|
||||
setActive $ ActiveG localDisplayName
|
||||
pure $ CRSentGroupInvitation gInfo contact member
|
||||
pure $ CRSentGroupInvitation gInfo contact member incognitoProfile
|
||||
case contactMember contact members of
|
||||
Nothing -> do
|
||||
gVar <- asks idsDrg
|
||||
(agentConnId, cReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
member <- withStore $ \db -> createContactMember db gVar user groupId contact memRole agentConnId cReq
|
||||
member <- withStore $ \db -> createNewContactMember db gVar user groupId contact memRole agentConnId cReq
|
||||
sendInvitation member cReq
|
||||
Just member@GroupMember {groupMemberId, memberStatus}
|
||||
| memberStatus == GSMemInvited ->
|
||||
@@ -719,13 +743,30 @@ processChatCommand = \case
|
||||
APIJoinGroup groupId -> withUser $ \user@User {userId} -> do
|
||||
ReceivedGroupInvitation {fromMember, connRequest, groupInfo = g@GroupInfo {membership}} <- withStore $ \db -> getGroupInvitation db user groupId
|
||||
withChatLock . procCmd $ do
|
||||
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage . XGrpAcpt $ memberId (membership :: GroupMember)
|
||||
-- [incognito] if (incognito mode is enabled OR direct connection with host is incognito) [AND membership is not incognito] update membership to use incognito profile
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
hostConnIncognito <- case (incognito, memberContactId fromMember) of
|
||||
(True, _) -> pure True -- we don't need to check whether connection with host is incognito if incognito mode is on
|
||||
(_, Just hostContactId) -> do
|
||||
hostContact <- withStore $ \db -> getContact db userId hostContactId
|
||||
pure $ contactConnIncognito hostContact
|
||||
_ -> pure False
|
||||
g'@GroupInfo {membership = membership'} <-
|
||||
if (incognito || hostConnIncognito) && not (memberIncognito membership)
|
||||
then do
|
||||
incognitoProfile <- liftIO generateRandomProfile
|
||||
membership' <- withStore $ \db -> createMemberIncognitoProfile db userId membership (Just incognitoProfile)
|
||||
pure g {membership = membership'}
|
||||
else pure g
|
||||
-- [incognito] if membership is incognito, send its incognito profile in XGrpAcpt
|
||||
let incognitoProfile = if memberIncognito membership' then Just (fromLocalProfile $ memberProfile membership') else Nothing
|
||||
agentConnId <- withAgent $ \a -> joinConnection a connRequest . directMessage $ XGrpAcpt (memberId (membership' :: GroupMember)) incognitoProfile
|
||||
withStore' $ \db -> do
|
||||
createMemberConnection db userId fromMember agentConnId
|
||||
updateGroupMemberStatus db userId fromMember GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership GSMemAccepted
|
||||
updateGroupMemberStatus db userId membership' GSMemAccepted
|
||||
updateCIGroupInvitationStatus user
|
||||
pure $ CRUserAcceptedGroupSent g {membership = membership {memberStatus = GSMemAccepted}}
|
||||
pure $ CRUserAcceptedGroupSent g' {membership = membership' {memberStatus = GSMemAccepted}}
|
||||
where
|
||||
updateCIGroupInvitationStatus user@User {userId} = do
|
||||
AChatItem _ _ cInfo ChatItem {content, meta = CIMeta {itemId}} <- withStore $ \db -> getChatItemByGroupId db user groupId
|
||||
@@ -750,7 +791,7 @@ processChatCommand = \case
|
||||
withStore' $ \db -> deleteGroupMember db user m
|
||||
_ -> do
|
||||
msg <- sendGroupMessage gInfo members $ XGrpMemDel mId
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId memberProfile) Nothing Nothing
|
||||
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) Nothing Nothing
|
||||
toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci
|
||||
deleteMemberConnection m
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemRemoved
|
||||
@@ -861,12 +902,12 @@ processChatCommand = \case
|
||||
pure $ CRRcvFileCancelled ftr
|
||||
FileStatus fileId ->
|
||||
CRFileTransferStatus <$> withUser (\user -> withStore $ \db -> getFileTransferProgress db user fileId)
|
||||
ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile profile
|
||||
ShowProfile -> withUser $ \User {profile} -> pure $ CRUserProfile (fromLocalProfile profile)
|
||||
UpdateProfile displayName fullName -> withUser $ \user@User {profile} -> do
|
||||
let p = (profile :: Profile) {displayName = displayName, fullName = fullName}
|
||||
let p = (fromLocalProfile profile :: Profile) {displayName = displayName, fullName = fullName}
|
||||
updateProfile user p
|
||||
UpdateProfileImage image -> withUser $ \user@User {profile} -> do
|
||||
let p = (profile :: Profile) {image}
|
||||
let p = (fromLocalProfile profile :: Profile) {image}
|
||||
updateProfile user p
|
||||
QuitChat -> liftIO exitSuccess
|
||||
ShowVersion -> pure $ CRVersionInfo versionNumber
|
||||
@@ -910,10 +951,18 @@ processChatCommand = \case
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> (asks idsDrg >>= liftIO . (`randomBytes` 16))
|
||||
xContactId <- maybe randomXContactId pure xContactId_
|
||||
connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profile $ Just xContactId)
|
||||
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId
|
||||
-- [incognito] generate profile to send
|
||||
-- if user makes a contact request using main profile, then turns on incognito mode and repeats the request,
|
||||
-- an incognito profile will be sent even though the address holder will have user's main profile received as well;
|
||||
-- we ignore this edge case as we already allow profile updates on repeat contact requests;
|
||||
-- alternatively we can re-send the main profile even if incognito mode is enabled
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = fromMaybe profile incognitoProfile
|
||||
connId <- withAgent $ \a -> joinConnection a cReq $ directMessage (XContact profileToSend $ Just xContactId)
|
||||
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile
|
||||
toView $ CRNewContactConnection conn
|
||||
pure CRSentInvitation
|
||||
pure $ CRSentInvitation incognitoProfile
|
||||
contactMember :: Contact -> [GroupMember] -> Maybe GroupMember
|
||||
contactMember Contact {contactId} =
|
||||
find $ \GroupMember {memberContactId = cId, memberStatus = s} ->
|
||||
@@ -924,17 +973,20 @@ processChatCommand = \case
|
||||
unlessM (doesFileExist fsFilePath) . throwChatError $ CEFileNotFound f
|
||||
(,) <$> getFileSize fsFilePath <*> asks (fileChunkSize . config)
|
||||
updateProfile :: User -> Profile -> m ChatResponse
|
||||
updateProfile user@User {profile = p} p'@Profile {displayName}
|
||||
| p' == p = pure CRUserProfileNoChange
|
||||
updateProfile user@User {profile = p@LocalProfile {profileId}} p'@Profile {displayName}
|
||||
| p' == fromLocalProfile p = pure CRUserProfileNoChange
|
||||
| otherwise = do
|
||||
withStore $ \db -> updateUserProfile db user p'
|
||||
let user' = (user :: User) {localDisplayName = displayName, profile = p'}
|
||||
let user' = (user :: User) {localDisplayName = displayName, profile = toLocalProfile profileId p'}
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user')
|
||||
contacts <- filter isReady <$> withStore' (`getUserContacts` user)
|
||||
-- [incognito] filter out contacts with whom user has incognito connections
|
||||
contacts <-
|
||||
filter (\ct -> isReady ct && not (contactConnIncognito ct))
|
||||
<$> withStore' (`getUserContacts` user)
|
||||
withChatLock . procCmd $ do
|
||||
forM_ contacts $ \ct ->
|
||||
void (sendDirectContactMessage ct $ XInfo p') `catchError` (toView . CRChatError)
|
||||
pure $ CRUserProfileUpdated p p'
|
||||
pure $ CRUserProfileUpdated (fromLocalProfile p) p'
|
||||
isReady :: Contact -> Bool
|
||||
isReady ct =
|
||||
let s = connStatus $ activeConn (ct :: Contact)
|
||||
@@ -1117,8 +1169,12 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, fileInvitation = F
|
||||
|
||||
acceptContactRequest :: ChatMonad m => User -> UserContactRequest -> m Contact
|
||||
acceptContactRequest User {userId, profile} UserContactRequest {agentInvitationId = AgentInvId invId, localDisplayName = cName, profileId, profile = p, userContactLinkId, xContactId} = do
|
||||
connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profile
|
||||
withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId
|
||||
-- [incognito] generate profile to send, create connection with incognito profile
|
||||
incognito <- readTVarIO =<< asks incognitoMode
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile
|
||||
connId <- withAgent $ \a -> acceptContact a invId . directMessage $ XInfo profileToSend
|
||||
withStore' $ \db -> createAcceptedContact db userId connId cName profileId p userContactLinkId xContactId incognitoProfile
|
||||
|
||||
agentSubscriber :: (MonadUnliftIO m, MonadReader ChatController m) => m ()
|
||||
agentSubscriber = do
|
||||
@@ -1192,7 +1248,7 @@ subscribeUserConnections agentBatchSubscribe user = do
|
||||
groupSubsToView :: Map ConnId (Either AgentErrorType ()) -> [Group] -> Map ConnId GroupMember -> Bool -> m ()
|
||||
groupSubsToView rs gs ms ce = do
|
||||
mapM_ groupSub $
|
||||
sortBy (comparing $ \(Group GroupInfo {localDisplayName = g} _) -> g) gs
|
||||
sortOn (\(Group GroupInfo {localDisplayName = g} _) -> g) gs
|
||||
toView . CRMemberSubSummary $ map (uncurry MemberSubStatus) mRs
|
||||
where
|
||||
mRs = resultsFor rs ms
|
||||
@@ -1293,11 +1349,14 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
_ -> Nothing
|
||||
|
||||
processDirectMessage :: ACommand 'Agent -> Connection -> Maybe Contact -> m ()
|
||||
processDirectMessage agentMsg conn@Connection {connId, viaUserContactLink} = \case
|
||||
processDirectMessage agentMsg conn@Connection {connId, viaUserContactLink, customUserProfileId} = \case
|
||||
Nothing -> case agentMsg of
|
||||
CONF confId _ connInfo -> do
|
||||
-- [incognito] send saved profile
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
let profileToSend = fromMaybe (fromLocalProfile profile) incognitoProfile
|
||||
saveConnInfo conn connInfo
|
||||
allowAgentConnection conn confId $ XInfo profile
|
||||
allowAgentConnection conn confId $ XInfo profileToSend
|
||||
INFO connInfo ->
|
||||
saveConnInfo conn connInfo
|
||||
MSG meta _msgFlags msgBody -> do
|
||||
@@ -1358,7 +1417,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
CON ->
|
||||
withStore' (\db -> getViaGroupMember db user ct) >>= \case
|
||||
Nothing -> do
|
||||
toView $ CRContactConnected ct
|
||||
-- [incognito] print incognito profile used for this contact
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
toView $ CRContactConnected ct incognitoProfile
|
||||
setActive $ ActiveC c
|
||||
showToast (c <> "> ") "connected"
|
||||
forM_ viaUserContactLink $ \userContactLinkId -> do
|
||||
@@ -1386,25 +1447,26 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
-- TODO print errors
|
||||
MERR msgId err -> do
|
||||
chatItemId_ <- withStore' $ \db -> getChatItemIdByAgentMsgId db connId msgId
|
||||
case chatItemId_ of
|
||||
Nothing -> pure ()
|
||||
Just chatItemId -> do
|
||||
chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId chatItemId (agentErrToItemStatus err)
|
||||
toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
forM_ chatItemId_ $ \chatItemId -> do
|
||||
chatItem <- withStore $ \db -> updateDirectChatItemStatus db userId contactId chatItemId (agentErrToItemStatus err)
|
||||
toView $ CRChatItemStatusUpdated (AChatItem SCTDirect SMDSnd (DirectChat ct) chatItem)
|
||||
ERR err -> toView . CRChatError $ ChatErrorAgent err
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
|
||||
processGroupMessage :: ACommand 'Agent -> Connection -> GroupInfo -> GroupMember -> m ()
|
||||
processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m = case agentMsg of
|
||||
processGroupMessage agentMsg conn gInfo@GroupInfo {groupId, localDisplayName = gName, membership} m@GroupMember {memberContactProfileId} = case agentMsg of
|
||||
CONF confId _ connInfo -> do
|
||||
ChatMessage {chatMsgEvent} <- liftEither $ parseChatMessage connInfo
|
||||
case memberCategory m of
|
||||
GCInviteeMember ->
|
||||
case chatMsgEvent of
|
||||
XGrpAcpt memId
|
||||
XGrpAcpt memId incognitoProfile
|
||||
| sameMemberId memId m -> do
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemAccepted
|
||||
-- [incognito] update member profile to incognito profile
|
||||
withStore $ \db -> do
|
||||
liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
||||
void $ createMemberIncognitoProfile db userId m incognitoProfile
|
||||
allowAgentConnection conn confId XOk
|
||||
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
|
||||
_ -> messageError "CONF from invited member must have x.grp.acpt"
|
||||
@@ -1413,7 +1475,8 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
XGrpMemInfo memId _memProfile
|
||||
| sameMemberId memId m -> do
|
||||
-- TODO update member profile
|
||||
allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) profile
|
||||
-- [incognito] send membership incognito profile
|
||||
allowAgentConnection conn confId $ XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
|
||||
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
||||
_ -> messageError "CONF from member must have x.grp.mem.info"
|
||||
INFO connInfo -> do
|
||||
@@ -1436,13 +1499,17 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
sendPendingGroupMessages m conn
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
|
||||
-- [incognito] chat item & event with indication that host connected incognito
|
||||
mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing
|
||||
memberConnectedChatItem gInfo m mainProfile
|
||||
toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} (memberIncognito membership)
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) "you are connected to group"
|
||||
GCInviteeMember -> do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRJoinedGroupMember gInfo m {memberStatus = GSMemConnected}
|
||||
-- [incognito] chat item & event with indication that invitee connected incognito
|
||||
mainProfile <- if memberIncognito m then Just <$> withStore (\db -> getProfileById db userId memberContactProfileId) else pure Nothing
|
||||
memberConnectedChatItem gInfo m mainProfile
|
||||
toView $ CRJoinedGroupMember gInfo m {memberStatus = GSMemConnected} mainProfile
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
|
||||
intros <- withStore' $ \db -> createIntroductions db members m
|
||||
@@ -1629,10 +1696,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
cancelRcvFileTransfer user ft
|
||||
throwChatError $ CEFileRcvChunk err
|
||||
|
||||
memberConnectedChatItem :: GroupInfo -> GroupMember -> m ()
|
||||
memberConnectedChatItem gInfo m = do
|
||||
memberConnectedChatItem :: GroupInfo -> GroupMember -> Maybe Profile -> m ()
|
||||
memberConnectedChatItem gInfo m mainProfile_ = do
|
||||
createdAt <- liftIO getCurrentTime
|
||||
let content = CIRcvGroupEvent RGEMemberConnected
|
||||
let content = CIRcvGroupEvent $ case mainProfile_ of
|
||||
Just mainProfile -> RGEMemberConnected $ Just mainProfile
|
||||
_ -> RGEMemberConnected Nothing
|
||||
cd = CDGroupRcv gInfo m
|
||||
-- first ts should be broker ts but we don't have it for CON
|
||||
ciId <- withStore' $ \db -> createNewChatItemNoMsg db user cd content createdAt createdAt
|
||||
@@ -1641,7 +1710,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
|
||||
notifyMemberConnected :: GroupInfo -> GroupMember -> m ()
|
||||
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do
|
||||
memberConnectedChatItem gInfo m
|
||||
memberConnectedChatItem gInfo m Nothing
|
||||
toView $ CRConnectedToGroupMember gInfo m
|
||||
let g = groupName' gInfo
|
||||
setActive $ ActiveG g
|
||||
@@ -1679,13 +1748,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
setActive $ ActiveC c
|
||||
|
||||
processFileInvitation :: Maybe FileInvitation -> (FileInvitation -> Integer -> m RcvFileTransfer) -> m (Maybe (CIFile 'MDRcv))
|
||||
processFileInvitation fileInvitation_ createRcvFileTransferF = case fileInvitation_ of
|
||||
Nothing -> pure Nothing
|
||||
Just fileInvitation@FileInvitation {fileName, fileSize} -> do
|
||||
processFileInvitation fileInvitation_ createRcvFileTransferF =
|
||||
forM fileInvitation_ $ \fileInvitation@FileInvitation {fileName, fileSize} -> do
|
||||
chSize <- asks $ fileChunkSize . config
|
||||
RcvFileTransfer {fileId} <- createRcvFileTransferF fileInvitation chSize
|
||||
let ciFile = CIFile {fileId, fileName, fileSize, filePath = Nothing, fileStatus = CIFSRcvInvitation}
|
||||
pure $ Just ciFile
|
||||
pure ciFile
|
||||
|
||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> m ()
|
||||
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta = do
|
||||
@@ -1830,16 +1898,19 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
toView . CRNewChatItem $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci
|
||||
|
||||
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processGroupInvitation ct@Contact {localDisplayName = c} inv@(GroupInvitation (MemberIdRole fromMemId fromRole) (MemberIdRole memId memRole) _ _) msg msgMeta = do
|
||||
processGroupInvitation ct@Contact {localDisplayName = c} inv@GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), fromMemberProfile, invitedMember = (MemberIdRole memId memRole)} msg msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
||||
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
||||
gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = GroupMember {groupMemberId}} <- withStore $ \db -> createGroupInvitation db user ct inv
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
-- [incognito] if received group invitation has host's incognito profile, create membership with new incognito profile; incognito mode is checked when joining group
|
||||
let invitedIncognito = isJust fromMemberProfile
|
||||
incognitoProfile <- if invitedIncognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership = GroupMember {groupMemberId}} <- withStore $ \db -> createGroupInvitation db user ct inv incognitoProfile
|
||||
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending, invitedIncognito = Just invitedIncognito}) memRole
|
||||
ci <- saveRcvChatItem user (CDDirectRcv ct) msg msgMeta content Nothing
|
||||
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
||||
toView . CRNewChatItem $ AChatItem SCTDirect SMDRcv (DirectChat ct) ci
|
||||
toView $ CRReceivedGroupInvitation gInfo ct memRole
|
||||
toView $ CRReceivedGroupInvitation gInfo ct memRole fromMemberProfile
|
||||
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
|
||||
|
||||
checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> m ()
|
||||
@@ -1857,23 +1928,27 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
toView $ CRNewChatItem $ AChatItem (chatTypeI @c) SMDRcv (toChatInfo cd) ci
|
||||
|
||||
xInfo :: Contact -> Profile -> m ()
|
||||
xInfo c@Contact {profile = p} p' = unless (p == p') $ do
|
||||
xInfo c@Contact {profile = p} p' = unless (fromLocalProfile p == p') $ do
|
||||
c' <- withStore $ \db -> updateContactProfile db userId c p'
|
||||
toView $ CRContactUpdated c c'
|
||||
|
||||
xInfoProbe :: Contact -> Probe -> m ()
|
||||
xInfoProbe c2 probe = do
|
||||
r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe
|
||||
forM_ r $ \c1 -> probeMatch c1 c2 probe
|
||||
xInfoProbe c2 probe =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c2) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbe db userId c2 probe
|
||||
forM_ r $ \c1 -> probeMatch c1 c2 probe
|
||||
|
||||
xInfoProbeCheck :: Contact -> ProbeHash -> m ()
|
||||
xInfoProbeCheck c1 probeHash = do
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash
|
||||
forM_ r . uncurry $ probeMatch c1
|
||||
xInfoProbeCheck c1 probeHash =
|
||||
-- [incognito] unless connected incognito
|
||||
unless (contactConnIncognito c1) $ do
|
||||
r <- withStore' $ \db -> matchReceivedProbeHash db userId c1 probeHash
|
||||
forM_ r . uncurry $ probeMatch c1
|
||||
|
||||
probeMatch :: Contact -> Contact -> Probe -> m ()
|
||||
probeMatch c1@Contact {profile = p1} c2@Contact {profile = p2} probe =
|
||||
when (p1 == p2) $ do
|
||||
when (fromLocalProfile p1 == fromLocalProfile p2) $ do
|
||||
void . sendDirectContactMessage c1 $ XInfoProbeOk probe
|
||||
mergeContacts c1 c2
|
||||
|
||||
@@ -2009,7 +2084,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
toView $ CRJoinedGroupMemberConnecting gInfo m newMember
|
||||
|
||||
xGrpMemIntro :: Connection -> GroupInfo -> GroupMember -> MemberInfo -> m ()
|
||||
xGrpMemIntro conn gInfo@GroupInfo {groupId} m memInfo@(MemberInfo memId _ _) = do
|
||||
xGrpMemIntro conn gInfo@GroupInfo {groupId, membership} m memInfo@(MemberInfo memId _ _) = do
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
@@ -2018,7 +2093,9 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
else do
|
||||
(groupConnId, groupConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
(directConnId, directConnReq) <- withAgent (`createConnection` SCMInvitation)
|
||||
newMember <- withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnId directConnId
|
||||
-- [incognito] direct connection with member has to be established using same incognito profile
|
||||
customUserProfileId <- if memberIncognito membership then Just <$> withStore (\db -> getGroupMemberProfileId db userId membership) else pure Nothing
|
||||
newMember <- withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnId directConnId customUserProfileId
|
||||
let msg = XGrpMemInv memId IntroInvitation {groupConnReq, directConnReq}
|
||||
void $ sendDirectMessage conn msg (GroupId groupId)
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId newMember GSMemIntroInvited
|
||||
@@ -2047,10 +2124,12 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
Nothing -> withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced
|
||||
Just m' -> pure m'
|
||||
withStore' $ \db -> saveMemberInvitation db toMember introInv
|
||||
let msg = XGrpMemInfo (memberId (membership :: GroupMember)) profile
|
||||
-- [incognito] send membership incognito profile, create direct connection as incognito
|
||||
let msg = XGrpMemInfo (memberId (membership :: GroupMember)) (fromLocalProfile $ memberProfile membership)
|
||||
groupConnId <- withAgent $ \a -> joinConnection a groupConnReq $ directMessage msg
|
||||
directConnId <- withAgent $ \a -> joinConnection a directConnReq $ directMessage msg
|
||||
withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId
|
||||
customUserProfileId <- if memberIncognito membership then Just <$> withStore (\db -> getGroupMemberProfileId db userId membership) else pure Nothing
|
||||
withStore' $ \db -> createIntroToMemberContact db userId m toMember groupConnId directConnId customUserProfileId
|
||||
|
||||
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> MsgMeta -> m ()
|
||||
xGrpMemDel gInfo@GroupInfo {membership} m memId msg msgMeta = do
|
||||
@@ -2071,7 +2150,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
|
||||
else do
|
||||
deleteMemberConnection member
|
||||
withStore' $ \db -> updateGroupMemberStatus db userId member GSMemRemoved
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId memberProfile) Nothing
|
||||
ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)) Nothing
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
toView $ CRDeletedMember gInfo m member {memberStatus = GSMemRemoved}
|
||||
|
||||
@@ -2388,7 +2467,7 @@ getCreateActiveUser st = do
|
||||
withTransaction st (`setActiveUser` userId user)
|
||||
pure user
|
||||
userStr :: User -> String
|
||||
userStr User {localDisplayName, profile = Profile {fullName}} =
|
||||
userStr User {localDisplayName, profile = LocalProfile {fullName}} =
|
||||
T.unpack $ localDisplayName <> if T.null fullName || localDisplayName == fullName then "" else " (" <> fullName <> ")"
|
||||
getContactName :: IO ContactName
|
||||
getContactName = do
|
||||
@@ -2556,6 +2635,7 @@ chatCommandP =
|
||||
"/profile_image" $> UpdateProfileImage Nothing,
|
||||
("/profile " <|> "/p ") *> (uncurry UpdateProfile <$> userNames),
|
||||
("/profile" <|> "/p") $> ShowProfile,
|
||||
"/incognito " *> (SetIncognito <$> onOffP),
|
||||
("/quit" <|> "/q" <|> "/exit") $> QuitChat,
|
||||
("/version" <|> "/v") $> ShowVersion
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user