dandri/simplex-chat
1
0
Fork 0
mirror of https://github.com/simplex-chat/simplex-chat.git synced 2026-04-29 01:47:44 +00:00
Code Issues Packages Projects Releases Wiki Activity

core: rework incognito mode - set per connection (#2838)

Browse Source
This commit is contained in:
spaced4ndy
2023-08-03 17:41:23 +04:00
committed by GitHub
parent b23b109b00
commit 4e27a4ea4f
10 changed files with 292 additions and 120 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Simplex/Chat.hs
+45 -38
View File
@@ -193,7 +193,6 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
rcvFiles <- newTVarIO M.empty
currentCalls <- atomically TM.empty
filesFolder <- newTVarIO optFilesFolder
incognitoMode <- newTVarIO False
chatStoreChanged <- newTVarIO False
expireCIThreads <- newTVarIO M.empty
expireCIFlags <- newTVarIO M.empty
@@ -202,7 +201,7 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
showLiveItems <- newTVarIO False
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
tempDirectory <- newTVarIO tempDir
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, incognitoMode, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile}
where
configServers :: DefaultAgentServers
configServers =
@@ -473,9 +472,6 @@ processChatCommand = \case
APISetXFTPConfig cfg -> do
asks userXFTPFileConfig >>= atomically . (`writeTVar` cfg)
ok_
SetIncognito onOff -> do
asks incognitoMode >>= atomically . (`writeTVar` onOff)
ok_
APIExportArchive cfg -> checkChatStopped $ exportArchive cfg >> ok_
ExportArchive -> do
ts <- liftIO getCurrentTime
@@ -930,10 +926,9 @@ processChatCommand = \case
pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo)
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
APIAcceptContact connReqId -> withUser $ \_ -> withChatLock "acceptContact" $ do
APIAcceptContact incognito connReqId -> withUser $ \_ -> withChatLock "acceptContact" $ do
(user, cReq) <- withStore $ \db -> getContactRequest' db connReqId
-- [incognito] generate profile to send, create connection with incognito profile
incognito <- readTVarIO =<< asks incognitoMode
incognitoProfile <- if incognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
ct <- acceptContactRequest user cReq incognitoProfile
pure $ CRAcceptingContactRequest user ct
@@ -1239,32 +1234,45 @@ processChatCommand = \case
EnableGroupMember gName mName -> withMemberName gName mName $ \gId mId -> APIEnableGroupMember gId mId
ChatHelp section -> pure $ CRChatHelp section
Welcome -> withUser $ pure . CRWelcome
APIAddContact userId -> withUserId userId $ \user -> withChatLock "addContact" . procCmd $ do
APIAddContact userId incognito -> withUserId userId $ \user -> withChatLock "addContact" . procCmd $ do
-- [incognito] generate profile for connection
incognito <- readTVarIO =<< asks incognitoMode
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
(connId, cReq) <- withAgent $ \a -> createConnection a (aUserId user) True SCMInvitation Nothing
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnNew incognitoProfile
toView $ CRNewContactConnection user conn
pure $ CRInvitation user cReq
AddContact -> withUser $ \User {userId} ->
processChatCommand $ APIAddContact userId
APIConnect userId (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
pure $ CRInvitation user cReq conn
AddContact incognito -> withUser $ \User {userId} ->
processChatCommand $ APIAddContact userId incognito
APISetConnectionIncognito connId incognito -> withUser $ \user@User {userId} -> do
conn'_ <- withStore $ \db -> do
conn@PendingContactConnection {pccConnStatus, customUserProfileId} <- getPendingContactConnection db userId connId
case (pccConnStatus, customUserProfileId, incognito) of
(ConnNew, Nothing, True) -> liftIO $ do
incognitoProfile <- generateRandomProfile
pId <- createIncognitoProfile db user incognitoProfile
Just <$> updatePCCIncognito db user conn (Just pId)
(ConnNew, Just pId, False) -> liftIO $ do
deletePCCIncognitoProfile db user pId
Just <$> updatePCCIncognito db user conn Nothing
_ -> pure Nothing
case conn'_ of
Just conn' -> pure $ CRConnectionIncognitoUpdated user conn'
Nothing -> throwChatError CEConnectionIncognitoChangeProhibited
APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
-- [incognito] generate profile to send
incognito <- readTVarIO =<< asks incognitoMode
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
let profileToSend = userProfileToSend user incognitoProfile Nothing
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq . directMessage $ XInfo profileToSend
conn <- withStore' $ \db -> createDirectConnection db user connId cReq ConnJoined $ incognitoProfile $> profileToSend
toView $ CRNewContactConnection user conn
pure $ CRSentConfirmation user
APIConnect userId (Just (ACR SCMContact cReq)) -> withUserId userId (`connectViaContact` cReq)
APIConnect _ Nothing -> throwChatError CEInvalidConnReq
Connect cReqUri -> withUser $ \User {userId} ->
processChatCommand $ APIConnect userId cReqUri
ConnectSimplex -> withUser $ \user ->
APIConnect userId incognito (Just (ACR SCMContact cReq)) -> withUserId userId $ \user -> connectViaContact user incognito cReq
APIConnect _ _ Nothing -> throwChatError CEInvalidConnReq
Connect incognito cReqUri -> withUser $ \User {userId} ->
processChatCommand $ APIConnect userId incognito cReqUri
ConnectSimplex incognito -> withUser $ \user ->
-- [incognito] generate profile to send
connectViaContact user adminContactReq
connectViaContact user incognito adminContactReq
DeleteContact cName -> withContactName cName $ APIDeleteChat . ChatRef CTDirect
ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect
APIListContacts userId -> withUserId userId $ \user ->
@@ -1308,9 +1316,9 @@ processChatCommand = \case
pure $ CRUserContactLinkUpdated user contactLink
AddressAutoAccept autoAccept_ -> withUser $ \User {userId} ->
processChatCommand $ APIAddressAutoAccept userId autoAccept_
AcceptContact cName -> withUser $ \User {userId} -> do
AcceptContact incognito cName -> withUser $ \User {userId} -> do
connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName
processChatCommand $ APIAcceptContact connReqId
processChatCommand $ APIAcceptContact incognito connReqId
RejectContact cName -> withUser $ \User {userId} -> do
connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName
processChatCommand $ APIRejectContact connReqId
@@ -1754,8 +1762,8 @@ processChatCommand = \case
CTDirect -> withStore $ \db -> getDirectChatItemIdByText' db user cId msg
CTGroup -> withStore $ \db -> getGroupChatItemIdByText' db user cId msg
_ -> throwChatError $ CECommandError "not supported"
connectViaContact :: User -> ConnectionRequestUri 'CMContact -> m ChatResponse
connectViaContact user@User {userId} cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
connectViaContact :: User -> IncognitoEnabled -> ConnectionRequestUri 'CMContact -> m ChatResponse
connectViaContact user@User {userId} incognito cReq@(CRContactUri ConnReqUriData {crClientData}) = withChatLock "connectViaContact" $ do
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
(Just contact, _) -> pure $ CRContactAlreadyExists user contact
@@ -1763,11 +1771,6 @@ processChatCommand = \case
let randomXContactId = XContactId <$> drgRandomBytes 16
xContactId <- maybe randomXContactId pure 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 = userProfileToSend user incognitoProfile Nothing
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq $ directMessage (XContact profileToSend $ Just xContactId)
@@ -3436,7 +3439,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
setActive $ ActiveG g
showToast ("#" <> g) $ "member " <> c <> " is connected"
probeMatchingContacts :: Contact -> Bool -> m ()
probeMatchingContacts :: Contact -> IncognitoEnabled -> m ()
probeMatchingContacts ct connectedIncognito = do
gVar <- asks idsDrg
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId ct
@@ -5033,7 +5036,7 @@ chatCommandP =
"/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP),
"/_delete " *> (APIDeleteChat <$> chatRefP),
"/_clear chat " *> (APIClearChat <$> chatRefP),
"/_accept " *> (APIAcceptContact <$> A.decimal),
"/_accept" *> (APIAcceptContact <$> incognitoOnOffP <* A.space <*> A.decimal),
"/_reject " *> (APIRejectContact <$> A.decimal),
"/_call invite @" *> (APISendCallInvitation <$> A.decimal <* A.space <*> jsonP),
"/call " *> char_ '@' *> (SendCallInvitation <$> displayName <*> pure defaultCallType),
@@ -5112,6 +5115,7 @@ chatCommandP =
("/help groups" <|> "/help group" <|> "/hg") $> ChatHelp HSGroups,
("/help contacts" <|> "/help contact" <|> "/hc") $> ChatHelp HSContacts,
("/help address" <|> "/ha") $> ChatHelp HSMyAddress,
"/help incognito" $> ChatHelp HSIncognito,
("/help messages" <|> "/hm") $> ChatHelp HSMessages,
("/help settings" <|> "/hs") $> ChatHelp HSSettings,
("/help db" <|> "/hd") $> ChatHelp HSDatabase,
@@ -5145,10 +5149,11 @@ chatCommandP =
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP),
"/_contacts " *> (APIListContacts <$> A.decimal),
"/contacts" $> ListContacts,
"/_connect " *> (APIConnect <$> A.decimal <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
"/_connect " *> (APIAddContact <$> A.decimal),
("/connect " <|> "/c ") *> (Connect <$> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
("/connect" <|> "/c") $> AddContact,
"/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
"/_connect " *> (APIAddContact <$> A.decimal <*> incognitoOnOffP),
"/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP),
("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)),
("/connect" <|> "/c") *> (AddContact <$> incognitoP),
SendMessage <$> chatNameP <* A.space <*> msgTextP,
"/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")),
(">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv),
@@ -5174,7 +5179,7 @@ chatCommandP =
"/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal),
("/fcancel " <|> "/fc ") *> (CancelFile <$> A.decimal),
("/fstatus " <|> "/fs ") *> (FileStatus <$> A.decimal),
"/simplex" $> ConnectSimplex,
"/simplex" *> (ConnectSimplex <$> incognitoP),
"/_address " *> (APICreateMyAddress <$> A.decimal),
("/address" <|> "/ad") $> CreateMyAddress,
"/_delete_address " *> (APIDeleteMyAddress <$> A.decimal),
@@ -5185,7 +5190,7 @@ chatCommandP =
("/profile_address " <|> "/pa ") *> (SetProfileAddress <$> onOffP),
"/_auto_accept " *> (APIAddressAutoAccept <$> A.decimal <* A.space <*> autoAcceptP),
"/auto_accept " *> (AddressAutoAccept <$> autoAcceptP),
("/accept " <|> "/ac ") *> char_ '@' *> (AcceptContact <$> displayName),
("/accept" <|> "/ac") *> (AcceptContact <$> incognitoP <* A.space <* char_ '@' <*> displayName),
("/reject " <|> "/rc ") *> char_ '@' *> (RejectContact <$> displayName),
("/markdown" <|> "/m") $> ChatHelp HSMarkdown,
("/welcome" <|> "/w") $> Welcome,
@@ -5207,7 +5212,7 @@ chatCommandP =
"/set disappear #" *> (SetGroupTimedMessages <$> displayName <*> (A.space *> timedTTLOnOffP)),
"/set disappear @" *> (SetContactTimedMessages <$> displayName <*> optional (A.space *> timedMessagesEnabledP)),
"/set disappear " *> (SetUserTimedMessages <$> (("yes" $> True) <|> ("no" $> False))),
"/incognito " *> (SetIncognito <$> onOffP),
("/incognito" <* optional (A.space *> onOffP)) $> ChatHelp HSIncognito,
("/quit" <|> "/q" <|> "/exit") $> QuitChat,
("/version" <|> "/v") $> ShowVersion,
"/debug locks" $> DebugLocks,
@@ -5216,6 +5221,8 @@ chatCommandP =
]
where
choice = A.choice . map (\p -> p <* A.takeWhile (== ' ') <* A.endOfInput)
incognitoP = (A.space *> ("incognito" <|> "i")) $> True <|> pure False
incognitoOnOffP = (A.space *> "incognito=" *> onOffP) <|> pure False
imagePrefix = (<>) <$> "data:" <*> ("image/png;base64," <|> "image/jpg;base64,")
imageP = safeDecodeUtf8 <$> ((<>) <$> imagePrefix <*> (B64.encode <$> base64P))
chatTypeP = A.char '@' $> CTDirect <|> A.char '#' $> CTGroup <|> A.char ':' $> CTContactConnection