Merge branch 'master-ghc8107' into master-android
This commit is contained in:
commit
41eb2e5689
@ -19,7 +19,11 @@ let bgSuspendTimeout: Int = 5 // seconds
|
||||
let terminationTimeout: Int = 3 // seconds
|
||||
|
||||
private func _suspendChat(timeout: Int) {
|
||||
if ChatModel.ok {
|
||||
// this is a redundant check to prevent logical errors, like the one fixed in this PR
|
||||
let state = appStateGroupDefault.get()
|
||||
if !state.canSuspend {
|
||||
logger.error("_suspendChat called, current state: \(state.rawValue, privacy: .public)")
|
||||
} else if ChatModel.ok {
|
||||
appStateGroupDefault.set(.suspending)
|
||||
apiSuspendChat(timeoutMicroseconds: timeout * 1000000)
|
||||
let endTask = beginBGTask(chatSuspended)
|
||||
@ -31,9 +35,7 @@ private func _suspendChat(timeout: Int) {
|
||||
|
||||
func suspendChat() {
|
||||
suspendLockQueue.sync {
|
||||
if appStateGroupDefault.get() != .stopped {
|
||||
_suspendChat(timeout: appSuspendTimeout)
|
||||
}
|
||||
_suspendChat(timeout: appSuspendTimeout)
|
||||
}
|
||||
}
|
||||
|
||||
@ -45,15 +47,25 @@ func suspendBgRefresh() {
|
||||
}
|
||||
}
|
||||
|
||||
private var terminating = false
|
||||
|
||||
func terminateChat() {
|
||||
logger.debug("terminateChat")
|
||||
suspendLockQueue.sync {
|
||||
switch appStateGroupDefault.get() {
|
||||
case .suspending:
|
||||
// suspend instantly if already suspending
|
||||
_chatSuspended()
|
||||
// when apiSuspendChat is called with timeout 0, it won't send any events on suspension
|
||||
if ChatModel.ok { apiSuspendChat(timeoutMicroseconds: 0) }
|
||||
case .stopped: ()
|
||||
chatCloseStore()
|
||||
case .suspended:
|
||||
chatCloseStore()
|
||||
case .stopped:
|
||||
chatCloseStore()
|
||||
default:
|
||||
terminating = true
|
||||
// the store will be closed in _chatSuspended when event is received
|
||||
_suspendChat(timeout: terminationTimeout)
|
||||
}
|
||||
}
|
||||
@ -73,10 +85,14 @@ private func _chatSuspended() {
|
||||
if ChatModel.shared.chatRunning == true {
|
||||
ChatReceiver.shared.stop()
|
||||
}
|
||||
if terminating {
|
||||
chatCloseStore()
|
||||
}
|
||||
}
|
||||
|
||||
func activateChat(appState: AppState = .active) {
|
||||
logger.debug("DEBUGGING: activateChat")
|
||||
terminating = false
|
||||
suspendLockQueue.sync {
|
||||
appStateGroupDefault.set(appState)
|
||||
if ChatModel.ok { apiActivateChat() }
|
||||
@ -85,6 +101,7 @@ func activateChat(appState: AppState = .active) {
|
||||
}
|
||||
|
||||
func initChatAndMigrate(refreshInvitations: Bool = true) {
|
||||
terminating = false
|
||||
let m = ChatModel.shared
|
||||
if (!m.chatInitialized) {
|
||||
do {
|
||||
@ -97,6 +114,7 @@ func initChatAndMigrate(refreshInvitations: Bool = true) {
|
||||
}
|
||||
|
||||
func startChatAndActivate() {
|
||||
terminating = false
|
||||
logger.debug("DEBUGGING: startChatAndActivate")
|
||||
if ChatModel.shared.chatRunning == true {
|
||||
ChatReceiver.shared.start()
|
||||
|
@ -50,6 +50,13 @@ public func chatMigrateInit(_ useKey: String? = nil, confirmMigrations: Migratio
|
||||
return result
|
||||
}
|
||||
|
||||
public func chatCloseStore() {
|
||||
let err = fromCString(chat_close_store(getChatCtrl()))
|
||||
if err != "" {
|
||||
logger.error("chatCloseStore error: \(err)")
|
||||
}
|
||||
}
|
||||
|
||||
public func resetChatCtrl() {
|
||||
chatController = nil
|
||||
migrationResult = nil
|
||||
|
@ -80,6 +80,14 @@ public enum AppState: String {
|
||||
default: return false
|
||||
}
|
||||
}
|
||||
|
||||
public var canSuspend: Bool {
|
||||
switch self {
|
||||
case .active: true
|
||||
case .bgRefresh: true
|
||||
default: false
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
public enum DBContainer: String {
|
||||
|
@ -17,6 +17,7 @@ typedef void* chat_ctrl;
|
||||
|
||||
// the last parameter is used to return the pointer to chat controller
|
||||
extern char *chat_migrate_init(char *path, char *key, char *confirm, chat_ctrl *ctrl);
|
||||
extern char *chat_close_store(chat_ctrl ctl);
|
||||
extern char *chat_send_cmd(chat_ctrl ctl, char *cmd);
|
||||
extern char *chat_recv_msg(chat_ctrl ctl);
|
||||
extern char *chat_recv_msg_wait(chat_ctrl ctl, int wait);
|
||||
|
@ -24,7 +24,7 @@ import Text.Read
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig opts Nothing mySquaringBot
|
||||
simplexChatCore terminalChatConfig opts mySquaringBot
|
||||
|
||||
welcomeGetOpts :: IO ChatOpts
|
||||
welcomeGetOpts = do
|
||||
|
@ -13,7 +13,7 @@ import Text.Read
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig opts Nothing $
|
||||
simplexChatCore terminalChatConfig opts $
|
||||
chatBotRepl welcomeMessage $ \_contact msg ->
|
||||
pure $ case readMaybe msg :: Maybe Integer of
|
||||
Just n -> msg <> " * " <> msg <> " = " <> show (n * n)
|
||||
|
@ -8,4 +8,4 @@ import Simplex.Chat.Terminal (terminalChatConfig)
|
||||
main :: IO ()
|
||||
main = do
|
||||
opts <- welcomeGetOpts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ broadcastBot opts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) $ broadcastBot opts
|
||||
|
@ -27,7 +27,7 @@ main = do
|
||||
welcome opts
|
||||
t <- withTerminal pure
|
||||
simplexChatTerminal terminalChatConfig opts t
|
||||
else simplexChatCore terminalChatConfig opts Nothing $ \user cc -> do
|
||||
else simplexChatCore terminalChatConfig opts $ \user cc -> do
|
||||
r <- sendChatCmdStr cc chatCmd
|
||||
ts <- getCurrentTime
|
||||
tz <- getCurrentTimeZone
|
||||
|
@ -29,7 +29,7 @@ import UnliftIO.STM
|
||||
|
||||
simplexChatServer :: ChatServerConfig -> ChatConfig -> ChatOpts -> IO ()
|
||||
simplexChatServer srvCfg cfg opts =
|
||||
simplexChatCore cfg opts Nothing . const $ runChatServer srvCfg
|
||||
simplexChatCore cfg opts . const $ runChatServer srvCfg
|
||||
|
||||
data ChatServerConfig = ChatServerConfig
|
||||
{ chatPort :: ServiceName,
|
||||
|
@ -12,4 +12,4 @@ main :: IO ()
|
||||
main = do
|
||||
opts@DirectoryOpts {directoryLog} <- welcomeGetOpts
|
||||
st <- restoreDirectoryStore directoryLog
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) Nothing $ directoryService st opts
|
||||
simplexChatCore terminalChatConfig (mkChatOpts opts) $ directoryService st opts
|
||||
|
@ -115,6 +115,7 @@ library
|
||||
Simplex.Chat.Migrations.M20230914_member_probes
|
||||
Simplex.Chat.Migrations.M20230926_contact_status
|
||||
Simplex.Chat.Migrations.M20231002_conn_initiated
|
||||
Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
|
||||
Simplex.Chat.Mobile
|
||||
Simplex.Chat.Mobile.File
|
||||
Simplex.Chat.Mobile.Shared
|
||||
|
@ -179,13 +179,11 @@ createChatDatabase filePrefix key confirmMigrations = runExceptT $ do
|
||||
agentStore <- ExceptT $ createAgentStore (agentStoreFile filePrefix) key confirmMigrations
|
||||
pure ChatDatabase {chatStore, agentStore}
|
||||
|
||||
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> IO ChatController
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} sendToast = do
|
||||
newChatController :: ChatDatabase -> Maybe User -> ChatConfig -> ChatOpts -> IO ChatController
|
||||
newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agentConfig = aCfg, defaultServers, inlineFiles, tempDir} ChatOpts {coreOptions = CoreChatOpts {smpServers, xftpServers, networkConfig, logLevel, logConnections, logServerHosts, logFile, tbqSize}, optFilesFolder, showReactions, allowInstantFiles, autoAcceptFileSize} = do
|
||||
let inlineFiles' = if allowInstantFiles || autoAcceptFileSize > 0 then inlineFiles else inlineFiles {sendChunks = 0, receiveInstant = False}
|
||||
config = cfg {logLevel, showReactions, tbqSize, subscriptionEvents = logConnections, hostEvents = logServerHosts, defaultServers = configServers, inlineFiles = inlineFiles', autoAcceptFileSize}
|
||||
sendNotification = fromMaybe (const $ pure ()) sendToast
|
||||
firstTime = dbNew chatStore
|
||||
activeTo <- newTVarIO ActiveNone
|
||||
currentUser <- newTVarIO user
|
||||
servers <- agentServers config
|
||||
smpAgent <- getSMPAgentClient aCfg {tbqSize} servers agentStore
|
||||
@ -193,7 +191,6 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
idsDrg <- newTVarIO =<< liftIO drgNew
|
||||
inputQ <- newTBQueueIO tbqSize
|
||||
outputQ <- newTBQueueIO tbqSize
|
||||
notifyQ <- newTBQueueIO tbqSize
|
||||
subscriptionMode <- newTVarIO SMSubscribe
|
||||
chatLock <- newEmptyTMVarIO
|
||||
sndFiles <- newTVarIO M.empty
|
||||
@ -209,7 +206,34 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
tempDirectory <- newTVarIO tempDir
|
||||
contactMergeEnabled <- newTVarIO True
|
||||
pure ChatController {activeTo, firstTime, currentUser, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile, contactMergeEnabled}
|
||||
pure
|
||||
ChatController
|
||||
{ firstTime,
|
||||
currentUser,
|
||||
smpAgent,
|
||||
agentAsync,
|
||||
chatStore,
|
||||
chatStoreChanged,
|
||||
idsDrg,
|
||||
inputQ,
|
||||
outputQ,
|
||||
subscriptionMode,
|
||||
chatLock,
|
||||
sndFiles,
|
||||
rcvFiles,
|
||||
currentCalls,
|
||||
config,
|
||||
filesFolder,
|
||||
expireCIThreads,
|
||||
expireCIFlags,
|
||||
cleanupManagerAsync,
|
||||
timedItemThreads,
|
||||
showLiveItems,
|
||||
userXFTPFileConfig,
|
||||
tempDirectory,
|
||||
logFilePath = logFile,
|
||||
contactMergeEnabled
|
||||
}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
@ -256,7 +280,7 @@ startChatController subConns enableExpireCIs startXFTPWorkers = do
|
||||
readTVarIO s >>= maybe (start s users) (pure . fst)
|
||||
where
|
||||
start s users = do
|
||||
a1 <- async $ race_ notificationSubscriber agentSubscriber
|
||||
a1 <- async agentSubscriber
|
||||
a2 <-
|
||||
if subConns
|
||||
then Just <$> async (subscribeUsers False users)
|
||||
@ -372,7 +396,6 @@ processChatCommand = \case
|
||||
user <- withStore $ \db -> createUserRecordAt db (AgentUserId auId) p True ts
|
||||
storeServers user smpServers
|
||||
storeServers user xftpServers
|
||||
setActive ActiveNone
|
||||
atomically . writeTVar u $ Just user
|
||||
pure $ CRActiveUser user
|
||||
where
|
||||
@ -398,7 +421,6 @@ processChatCommand = \case
|
||||
user' <- privateGetUser userId'
|
||||
validateUserPassword user user' viewPwd_
|
||||
withStoreCtx' (Just "APISetActiveUser, setActiveUser") $ \db -> setActiveUser db userId'
|
||||
setActive ActiveNone
|
||||
let user'' = user' {activeUser = True}
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user'')
|
||||
pure $ CRActiveUser user''
|
||||
@ -528,7 +550,7 @@ processChatCommand = \case
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIGetChatItems pagination search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user pagination search
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
APIGetChatItemInfo chatRef itemId -> withUser $ \user -> do
|
||||
(aci@(AChatItem cType dir _ ci), versions) <- withStore $ \db ->
|
||||
(,) <$> getAChatItem db user chatRef itemId <*> liftIO (getChatItemVersions db itemId)
|
||||
@ -542,7 +564,7 @@ processChatCommand = \case
|
||||
pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses}
|
||||
APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
ct@Contact {contactId, contactUsed} <- withStore $ \db -> getContact db user chatId
|
||||
assertDirectAllowed user MDSnd ct XMsgNew_
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
if isVoice mc && not (featureAllowed SCFVoice forUser ct)
|
||||
@ -559,7 +581,6 @@ processChatCommand = \case
|
||||
ci <- saveSndChatItem' user (CDDirectSnd ct) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live
|
||||
forM_ (timed_ >>= timedDeleteAt') $
|
||||
startProximateTimedItemThread user (ChatRef CTDirect contactId, chatItemId' ci)
|
||||
setActive $ ActiveC c
|
||||
pure $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
where
|
||||
setupSndFileTransfer :: Contact -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
@ -610,7 +631,7 @@ processChatCommand = \case
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
send g
|
||||
where
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms)
|
||||
send g@(Group gInfo@GroupInfo {groupId, membership} ms)
|
||||
| isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice
|
||||
| not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles
|
||||
| otherwise = do
|
||||
@ -625,7 +646,6 @@ processChatCommand = \case
|
||||
createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew
|
||||
forM_ (timed_ >>= timedDeleteAt') $
|
||||
startProximateTimedItemThread user (ChatRef CTGroup groupId, chatItemId' ci)
|
||||
setActive $ ActiveG gName
|
||||
pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f))
|
||||
setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta))
|
||||
@ -728,7 +748,7 @@ processChatCommand = \case
|
||||
unzipMaybe3 _ = (Nothing, Nothing, Nothing)
|
||||
APIUpdateChatItem (ChatRef cType chatId) itemId live mc -> withUser $ \user -> withChatLock "updateChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {contactId, localDisplayName = c}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct@Contact {contactId}, cci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
assertDirectAllowed user MDSnd ct XMsgUpdate_
|
||||
case cci of
|
||||
CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do
|
||||
@ -744,13 +764,12 @@ processChatCommand = \case
|
||||
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
|
||||
updateDirectChatItem' db user contactId ci (CISndMsgContent mc) live $ Just msgId
|
||||
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
|
||||
setActive $ ActiveC c
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci')
|
||||
else pure $ CRChatItemNotChanged user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate
|
||||
CTGroup -> do
|
||||
Group gInfo@GroupInfo {groupId, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId
|
||||
Group gInfo@GroupInfo {groupId} ms <- withStore $ \db -> getGroup db user chatId
|
||||
assertUserGroupRole gInfo GRAuthor
|
||||
cci <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case cci of
|
||||
@ -767,7 +786,6 @@ processChatCommand = \case
|
||||
addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc)
|
||||
updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId
|
||||
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
|
||||
setActive $ ActiveG gName
|
||||
pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci')
|
||||
else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci)
|
||||
_ -> throwChatError CEInvalidChatItemUpdate
|
||||
@ -776,13 +794,12 @@ processChatCommand = \case
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of
|
||||
CTDirect -> do
|
||||
(ct@Contact {localDisplayName = c}, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct, ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}})) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId, editable) of
|
||||
(CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
|
||||
assertDirectAllowed user MDSnd ct XMsgDel_
|
||||
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId Nothing)
|
||||
setActive $ ActiveC c
|
||||
if featureAllowed SCFFullDelete forUser ct
|
||||
then deleteDirectCI user ct ci True False
|
||||
else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime
|
||||
@ -892,11 +909,11 @@ processChatCommand = \case
|
||||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteChat (ChatRef cType chatId) notify -> withUser $ \user@User {userId} -> case cType of
|
||||
CTDirect -> do
|
||||
ct@Contact {localDisplayName} <- withStore $ \db -> getContact db user chatId
|
||||
ct <- withStore $ \db -> getContact db user chatId
|
||||
filesInfo <- withStore' $ \db -> getContactFileInfo db user ct
|
||||
withChatLock "deleteChat direct" . procCmd $ do
|
||||
deleteFilesAndConns user filesInfo
|
||||
when (isReady ct && contactActive ct && notify) $
|
||||
when (contactReady ct && contactActive ct && notify) $
|
||||
void (sendDirectContactMessage ct XDirectDel) `catchChatError` const (pure ())
|
||||
contactConnIds <- map aConnId <$> withStore (\db -> getContactConnections db userId ct)
|
||||
deleteAgentConnectionsAsync user contactConnIds
|
||||
@ -904,7 +921,6 @@ processChatCommand = \case
|
||||
-- (possibly, race condition on integrity check?)
|
||||
withStore' $ \db -> deleteContactConnectionsAndFiles db userId ct
|
||||
withStore' $ \db -> deleteContact db user ct
|
||||
unsetActive $ ActiveC localDisplayName
|
||||
pure $ CRContactDeleted user ct
|
||||
CTContactConnection -> withChatLock "deleteChat contactConnection" . procCmd $ do
|
||||
conn@PendingContactConnection {pccAgentConnId = AgentConnId acId} <- withStore $ \db -> getPendingContactConnection db userId chatId
|
||||
@ -1303,6 +1319,8 @@ processChatCommand = \case
|
||||
case conn'_ of
|
||||
Just conn' -> pure $ CRConnectionIncognitoUpdated user conn'
|
||||
Nothing -> throwChatError CEConnectionIncognitoChangeProhibited
|
||||
APIConnectPlan userId cReqUri -> withUserId userId $ \user -> withChatLock "connectPlan" . procCmd $
|
||||
CRConnectionPlan user <$> connectPlan user cReqUri
|
||||
APIConnect userId incognito (Just (ACR SCMInvitation cReq)) -> withUserId userId $ \user -> withChatLock "connect" . procCmd $ do
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
-- [incognito] generate profile to send
|
||||
@ -1315,11 +1333,16 @@ processChatCommand = \case
|
||||
pure $ CRSentConfirmation 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 incognito adminContactReq
|
||||
Connect incognito aCReqUri@(Just cReqUri) -> withUser $ \user@User {userId} -> do
|
||||
plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk)
|
||||
unless (connectionPlanOk plan) $ throwChatError (CEConnectionPlan plan)
|
||||
processChatCommand $ APIConnect userId incognito aCReqUri
|
||||
Connect _ Nothing -> throwChatError CEInvalidConnReq
|
||||
ConnectSimplex incognito -> withUser $ \user@User {userId} -> do
|
||||
let cReqUri = ACR SCMContact adminContactReq
|
||||
plan <- connectPlan user cReqUri `catchChatError` const (pure $ CPInvitationLink ILPOk)
|
||||
unless (connectionPlanOk plan) $ throwChatError (CEConnectionPlan plan)
|
||||
processChatCommand $ APIConnect userId incognito (Just cReqUri)
|
||||
DeleteContact cName -> withContactName cName $ \ctId -> APIDeleteChat (ChatRef CTDirect ctId) True
|
||||
ClearContact cName -> withContactName cName $ APIClearChat . ChatRef CTDirect
|
||||
APIListContacts userId -> withUserId userId $ \user ->
|
||||
@ -1415,7 +1438,7 @@ processChatCommand = \case
|
||||
processChatCommand . APISendMessage chatRef True Nothing $ ComposedMessage Nothing Nothing mc
|
||||
SendMessageBroadcast msg -> withUser $ \user -> do
|
||||
contacts <- withStore' (`getUserContacts` user)
|
||||
let cts = filter (\ct -> isReady ct && contactActive ct && directOrUsed ct) contacts
|
||||
let cts = filter (\ct -> contactReady ct && contactActive ct && directOrUsed ct) contacts
|
||||
ChatConfig {logLevel} <- asks config
|
||||
withChatLock "sendMessageBroadcast" . procCmd $ do
|
||||
(successes, failures) <- foldM (sendAndCount user logLevel) (0, 0) cts
|
||||
@ -1683,11 +1706,10 @@ processChatCommand = \case
|
||||
LastMessages (Just chatName) count search -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand $ APIGetChat chatRef (CPLast count) search
|
||||
setActive $ chatActiveTo chatName
|
||||
pure $ CRChatItems user (aChatItems . chat $ chatResp)
|
||||
pure $ CRChatItems user (Just chatName) (aChatItems . chat $ chatResp)
|
||||
LastMessages Nothing count search -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast count) search
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
LastChatItemId (Just chatName) index -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
chatResp <- processChatCommand (APIGetChat chatRef (CPLast $ index + 1) Nothing)
|
||||
@ -1699,10 +1721,10 @@ processChatCommand = \case
|
||||
chatItem <- withStore $ \db -> do
|
||||
chatRef <- getChatRefViaItemId db user itemId
|
||||
getAChatItem db user chatRef itemId
|
||||
pure $ CRChatItems user ((: []) chatItem)
|
||||
pure $ CRChatItems user Nothing ((: []) chatItem)
|
||||
ShowChatItem Nothing -> withUser $ \user -> do
|
||||
chatItems <- withStore $ \db -> getAllChatItems db user (CPLast 1) Nothing
|
||||
pure $ CRChatItems user chatItems
|
||||
pure $ CRChatItems user Nothing chatItems
|
||||
ShowChatItemInfo chatName msg -> withUser $ \user -> do
|
||||
chatRef <- getChatRef user chatName
|
||||
itemId <- getChatItemIdByText user chatRef msg
|
||||
@ -1916,19 +1938,36 @@ processChatCommand = \case
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
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
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> drgRandomBytes 16
|
||||
xContactId <- maybe randomXContactId pure xContactId_
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
|
||||
cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
|
||||
case groupLinkId of
|
||||
-- contact address
|
||||
Nothing ->
|
||||
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
|
||||
(Just contact, _) -> pure $ CRContactAlreadyExists user contact
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> drgRandomBytes 16
|
||||
xContactId <- maybe randomXContactId pure xContactId_
|
||||
connect' Nothing cReqHash xContactId
|
||||
-- group link
|
||||
Just gLinkId ->
|
||||
withStore' (\db -> getConnReqContactXContactId db user cReqHash) >>= \case
|
||||
(Just _contact, _) -> procCmd $ do
|
||||
-- allow repeat contact request
|
||||
newXContactId <- XContactId <$> drgRandomBytes 16
|
||||
connect' (Just gLinkId) cReqHash newXContactId
|
||||
(_, xContactId_) -> procCmd $ do
|
||||
let randomXContactId = XContactId <$> drgRandomBytes 16
|
||||
xContactId <- maybe randomXContactId pure xContactId_
|
||||
connect' (Just gLinkId) cReqHash xContactId
|
||||
where
|
||||
connect' groupLinkId cReqHash xContactId = do
|
||||
-- [incognito] generate profile to send
|
||||
incognitoProfile <- if incognito then Just <$> liftIO generateRandomProfile else pure Nothing
|
||||
let profileToSend = userProfileToSend user incognitoProfile Nothing
|
||||
dm <- directMessage (XContact profileToSend $ Just xContactId)
|
||||
subMode <- chatReadVar subscriptionMode
|
||||
connId <- withAgent $ \a -> joinConnection a (aUserId user) True cReq dm subMode
|
||||
let groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
|
||||
conn <- withStore' $ \db -> createConnReqConnection db userId connId cReqHash xContactId incognitoProfile groupLinkId subMode
|
||||
toView $ CRNewContactConnection user conn
|
||||
pure $ CRSentInvitation user incognitoProfile
|
||||
@ -1967,7 +2006,7 @@ processChatCommand = \case
|
||||
-- read contacts before user update to correctly merge preferences
|
||||
-- [incognito] filter out contacts with whom user has incognito connections
|
||||
contacts <-
|
||||
filter (\ct -> isReady ct && contactActive ct && not (contactConnIncognito ct))
|
||||
filter (\ct -> contactReady ct && contactActive ct && not (contactConnIncognito ct))
|
||||
<$> withStore' (`getUserContacts` user)
|
||||
user' <- updateUser
|
||||
asks currentUser >>= atomically . (`writeTVar` Just user')
|
||||
@ -2027,8 +2066,7 @@ processChatCommand = \case
|
||||
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
|
||||
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive
|
||||
delGroupChatItem :: User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> m ChatResponse
|
||||
delGroupChatItem user gInfo@GroupInfo {localDisplayName = gName} ci msgId byGroupMember = do
|
||||
setActive $ ActiveG gName
|
||||
delGroupChatItem user gInfo ci msgId byGroupMember = do
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci True False byGroupMember deletedTs
|
||||
@ -2038,10 +2076,6 @@ processChatCommand = \case
|
||||
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db ->
|
||||
getGroupIdByName db user gName >>= getGroup db user
|
||||
runUpdateGroupProfile user g $ update p
|
||||
isReady :: Contact -> Bool
|
||||
isReady ct =
|
||||
let s = connStatus $ activeConn (ct :: Contact)
|
||||
in s == ConnReady || s == ConnSndReady
|
||||
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
|
||||
withCurrentCall ctId action = do
|
||||
(user, ct) <- withStore $ \db -> do
|
||||
@ -2089,7 +2123,6 @@ processChatCommand = \case
|
||||
let content = CISndGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
||||
ci <- saveSndChatItem user (CDDirectSnd ct) msg content
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci)
|
||||
setActive $ ActiveG localDisplayName
|
||||
sndContactCITimed :: Bool -> Contact -> Maybe Int -> m (Maybe CITimed)
|
||||
sndContactCITimed live = sndCITimed_ live . contactTimedTTL
|
||||
sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> m (Maybe CITimed)
|
||||
@ -2139,7 +2172,6 @@ processChatCommand = \case
|
||||
users <- withStore' getUsers
|
||||
unless (length users > 1 && (isJust (viewPwdHash user) || length (filter (isNothing . viewPwdHash) users) > 1)) $
|
||||
throwChatError (CECantDeleteLastUser userId)
|
||||
setActive ActiveNone
|
||||
deleteChatUser :: User -> Bool -> m ChatResponse
|
||||
deleteChatUser user delSMPQueues = do
|
||||
filesInfo <- withStore' (`getUserFileInfo` user)
|
||||
@ -2160,6 +2192,54 @@ processChatCommand = \case
|
||||
pure (gId, chatSettings)
|
||||
_ -> throwChatError $ CECommandError "not supported"
|
||||
processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings
|
||||
connectPlan :: User -> AConnectionRequestUri -> m ConnectionPlan
|
||||
connectPlan user (ACR SCMInvitation cReq) = do
|
||||
withStore' (\db -> getConnectionEntityByConnReq db user cReq) >>= \case
|
||||
Nothing -> pure $ CPInvitationLink ILPOk
|
||||
Just (RcvDirectMsgConnection conn ct_) -> do
|
||||
let Connection {connStatus, contactConnInitiated} = conn
|
||||
if
|
||||
| connStatus == ConnNew && contactConnInitiated ->
|
||||
pure $ CPInvitationLink ILPOwnLink
|
||||
| not (connReady conn) ->
|
||||
pure $ CPInvitationLink (ILPConnecting ct_)
|
||||
| otherwise -> case ct_ of
|
||||
Just ct -> pure $ CPInvitationLink (ILPKnown ct)
|
||||
Nothing -> throwChatError $ CEInternalError "ready RcvDirectMsgConnection connection should have associated contact"
|
||||
Just _ -> throwChatError $ CECommandError "found connection entity is not RcvDirectMsgConnection"
|
||||
connectPlan user (ACR SCMContact cReq) = do
|
||||
let CRContactUri ConnReqUriData {crClientData} = cReq
|
||||
groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli
|
||||
case groupLinkId of
|
||||
-- contact address
|
||||
Nothing ->
|
||||
withStore' (`getUserContactLinkByConnReq` cReq) >>= \case
|
||||
Just _ -> pure $ CPContactAddress CAPOwnLink
|
||||
Nothing -> do
|
||||
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
|
||||
withStore' (\db -> getContactByConnReqHash db user cReqHash) >>= \case
|
||||
Nothing -> pure $ CPContactAddress CAPOk
|
||||
Just ct
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPContactAddress (CAPConnecting ct)
|
||||
| otherwise -> pure $ CPContactAddress (CAPKnown ct)
|
||||
-- group link
|
||||
Just _ ->
|
||||
withStore' (\db -> getGroupInfoByUserContactLinkConnReq db user cReq) >>= \case
|
||||
Just g -> pure $ CPGroupLink (GLPOwnLink g)
|
||||
Nothing -> do
|
||||
let cReqHash = ConnReqUriHash . C.sha256Hash $ strEncode cReq
|
||||
ct_ <- withStore' $ \db -> getContactByConnReqHash db user cReqHash
|
||||
gInfo_ <- withStore' $ \db -> getGroupInfoByGroupLinkHash db user cReqHash
|
||||
case (gInfo_, ct_) of
|
||||
(Nothing, Nothing) -> pure $ CPGroupLink GLPOk
|
||||
(Nothing, Just ct)
|
||||
| not (contactReady ct) && contactActive ct -> pure $ CPGroupLink (GLPConnecting gInfo_)
|
||||
| otherwise -> pure $ CPGroupLink GLPOk
|
||||
(Just gInfo@GroupInfo {membership}, _)
|
||||
| not (memberActive membership) && not (memberRemoved membership) ->
|
||||
pure $ CPGroupLink (GLPConnecting gInfo_)
|
||||
| memberActive membership -> pure $ CPGroupLink (GLPKnown gInfo)
|
||||
| otherwise -> pure $ CPGroupLink GLPOk
|
||||
|
||||
assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m ()
|
||||
assertDirectAllowed user dir ct event =
|
||||
@ -2791,17 +2871,16 @@ processAgentMessageNoConn :: forall m. ChatMonad m => ACommand 'Agent 'AENone ->
|
||||
processAgentMessageNoConn = \case
|
||||
CONNECT p h -> hostEvent $ CRHostConnected p h
|
||||
DISCONNECT p h -> hostEvent $ CRHostDisconnected p h
|
||||
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected "disconnected"
|
||||
UP srv conns -> serverEvent srv conns CRContactsSubscribed "connected"
|
||||
DOWN srv conns -> serverEvent srv conns CRContactsDisconnected
|
||||
UP srv conns -> serverEvent srv conns CRContactsSubscribed
|
||||
SUSPENDED -> toView CRChatSuspended
|
||||
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
|
||||
where
|
||||
hostEvent :: ChatResponse -> m ()
|
||||
hostEvent = whenM (asks $ hostEvents . config) . toView
|
||||
serverEvent srv@(SMPServer host _ _) conns event str = do
|
||||
cs <- withStore' $ \db -> getConnectionsContacts db conns
|
||||
serverEvent srv conns event = do
|
||||
cs <- withStore' (`getConnectionsContacts` conns)
|
||||
toView $ event srv cs
|
||||
showToast ("server " <> str) (safeDecodeUtf8 $ strEncode host)
|
||||
|
||||
processAgentMsgSndFile :: forall m. ChatMonad m => ACorrId -> SndFileId -> ACommand 'Agent 'AESndFile -> m ()
|
||||
processAgentMsgSndFile _corrId aFileId msg =
|
||||
@ -2938,10 +3017,7 @@ processAgentMsgRcvFile _corrId aFileId msg =
|
||||
processAgentMessageConn :: forall m. ChatMonad m => User -> ACorrId -> ConnId -> ACommand 'Agent 'AEConn -> m ()
|
||||
processAgentMessageConn user _ agentConnId END =
|
||||
withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= \case
|
||||
RcvDirectMsgConnection _ (Just ct@Contact {localDisplayName = c}) -> do
|
||||
toView $ CRContactAnotherClient user ct
|
||||
whenUserNtfs user $ showToast (c <> "> ") "connected to another client"
|
||||
unsetActive $ ActiveC c
|
||||
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
|
||||
entity -> toView $ CRSubscriptionEnd user entity
|
||||
processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
entity <- withStore (\db -> getConnectionEntity db user $ AgentConnId agentConnId) >>= updateConnStatus
|
||||
@ -3008,7 +3084,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
||||
-- TODO add debugging output
|
||||
_ -> pure ()
|
||||
Just ct@Contact {localDisplayName = c, contactId} -> case agentMsg of
|
||||
Just ct@Contact {contactId} -> case agentMsg of
|
||||
INV (ACR _ cReq) ->
|
||||
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
||||
withCompletedCommand conn agentMsg $ \_ ->
|
||||
@ -3093,9 +3169,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
||||
toView $ CRContactConnected user ct (fmap fromLocalProfile incognitoProfile)
|
||||
when (directOrUsed ct) $ createFeatureEnabledItems ct
|
||||
whenUserNtfs user $ do
|
||||
setActive $ ActiveC c
|
||||
showToast (c <> "> ") "connected"
|
||||
when (contactConnInitiated conn) $ do
|
||||
let Connection {groupLinkId} = conn
|
||||
doProbeContacts = isJust groupLinkId
|
||||
@ -3172,7 +3245,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> pure ()
|
||||
|
||||
processGroupMessage :: ACommand 'Agent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> m ()
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, localDisplayName = gName, groupProfile, membership, chatSettings} m = case agentMsg of
|
||||
processGroupMessage agentMsg connEntity conn@Connection {connId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
|
||||
INV (ACR _ cReq) ->
|
||||
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
|
||||
case cReq of
|
||||
@ -3262,15 +3335,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
||||
memberConnectedChatItem gInfo m
|
||||
forM_ description $ groupDescriptionChatItem gInfo m
|
||||
whenUserNtfs user $ do
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) "you are connected to group"
|
||||
GCInviteeMember -> do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
|
||||
whenGroupNtfs user gInfo $ do
|
||||
setActive $ ActiveG gName
|
||||
showToast ("#" <> gName) $ "member " <> localDisplayName (m :: GroupMember) <> " is connected"
|
||||
intros <- withStore' $ \db -> createIntroductions db members m
|
||||
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
|
||||
forM_ intros $ \intro ->
|
||||
@ -3565,7 +3632,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
profileContactRequest invId chatVRange p xContactId_ = do
|
||||
withStore (\db -> createOrUpdateContactRequest db user userContactLinkId invId chatVRange p xContactId_) >>= \case
|
||||
CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
|
||||
CORRequest cReq@UserContactRequest {localDisplayName} -> do
|
||||
CORRequest cReq -> do
|
||||
withStore' (\db -> getUserContactLinkById db userId userContactLinkId) >>= \case
|
||||
Just (UserContactLink {autoAccept}, groupId_, _) ->
|
||||
case autoAccept of
|
||||
@ -3580,10 +3647,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
||||
ct <- acceptContactRequestAsync user cReq profileMode
|
||||
toView $ CRAcceptingGroupJoinRequest user gInfo ct
|
||||
_ -> do
|
||||
toView $ CRReceivedContactRequest user cReq
|
||||
whenUserNtfs user $
|
||||
showToast (localDisplayName <> "> ") "wants to connect to you"
|
||||
_ -> toView $ CRReceivedContactRequest user cReq
|
||||
_ -> pure ()
|
||||
|
||||
incAuthErrCounter :: ConnectionEntity -> Connection -> AgentErrorType -> m ()
|
||||
@ -3674,13 +3738,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing
|
||||
|
||||
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m ()
|
||||
notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do
|
||||
notifyMemberConnected gInfo m ct_ = do
|
||||
memberConnectedChatItem gInfo m
|
||||
toView $ CRConnectedToGroupMember user gInfo m ct_
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
setActive $ ActiveG g
|
||||
showToast ("#" <> g) $ "member " <> c <> " is connected"
|
||||
|
||||
probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> m ()
|
||||
probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
|
||||
@ -3742,7 +3802,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
messageError = toView . CRMessageError user "error"
|
||||
|
||||
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newContentMessage ct@Contact {localDisplayName = c, contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc
|
||||
@ -3755,23 +3815,18 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
if isVoice content && not (featureAllowed SCFVoice forContact ct)
|
||||
then do
|
||||
void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
||||
setActive $ ActiveC c
|
||||
else do
|
||||
let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc
|
||||
timed_ = rcvContactCITimed ct itemTTL
|
||||
live = fromMaybe False live_
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct
|
||||
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
whenContactNtfs user ct $ do
|
||||
showMsgToast (c <> "> ") content formattedText
|
||||
setActive $ ActiveC c
|
||||
where
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions})
|
||||
pure ci
|
||||
|
||||
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> m ()
|
||||
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
|
||||
@ -3830,7 +3885,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
pure (ft, CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
|
||||
|
||||
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
||||
messageUpdate ct@Contact {contactId, localDisplayName = c} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
@ -3842,7 +3897,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateDirectChatItem' db user contactId ci content live Nothing
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
|
||||
setActive $ ActiveC c
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
@ -3929,7 +3983,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
e -> throwError e
|
||||
|
||||
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m ()
|
||||
newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
|
||||
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta
|
||||
| isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice
|
||||
| not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles
|
||||
| otherwise = do
|
||||
@ -3959,20 +4013,15 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView cr
|
||||
createItem timed_ live = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ChatItem {formattedText} <- newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
newChatItem (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
autoAcceptFile file_
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText
|
||||
setActive $ ActiveG g
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
|
||||
groupMsgToView gInfo m ci {reactions} msgMeta
|
||||
pure ci
|
||||
|
||||
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m ()
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
|
||||
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ =
|
||||
updateRcvChatItem `catchCINotFound` \_ -> do
|
||||
-- This patches initial sharedMsgId into chat item when locally deleted chat item
|
||||
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
|
||||
@ -3983,7 +4032,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content live Nothing
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
@ -4002,7 +4050,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
|
||||
updateGroupChatItem db user groupId ci content live $ Just msgId
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci'
|
||||
else toView $ CRChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
|
||||
else messageError "x.msg.update: group member attempted to update a message of another member"
|
||||
@ -4038,7 +4085,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
|
||||
-- TODO remove once XFile is discontinued
|
||||
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processFileInvitation' ct@Contact {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
processFileInvitation' ct fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
@ -4047,13 +4094,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
toView $ CRNewChatItem user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
||||
whenContactNtfs user ct $ do
|
||||
showToast (c <> "> ") "wants to send a file"
|
||||
setActive $ ActiveC c
|
||||
|
||||
-- TODO remove once XFile is discontinued
|
||||
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> MsgMeta -> m ()
|
||||
processGroupFileInvitation' gInfo m@GroupMember {localDisplayName = c} fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
||||
ChatConfig {fileChunkSize} <- asks config
|
||||
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
||||
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
|
||||
@ -4061,10 +4105,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False
|
||||
groupMsgToView gInfo m ci msgMeta
|
||||
let g = groupName' gInfo
|
||||
whenGroupNtfs user gInfo $ do
|
||||
showToast ("#" <> g <> " " <> c <> "> ") "wants to send a file"
|
||||
setActive $ ActiveG g
|
||||
|
||||
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
|
||||
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
|
||||
@ -4221,7 +4261,7 @@ 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 {peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = ct
|
||||
let Contact {localDisplayName = c, activeConn = Connection {connId, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'}} = 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)
|
||||
@ -4234,6 +4274,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
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
|
||||
@ -4244,8 +4285,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
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}
|
||||
whenContactNtfs user ct $
|
||||
showToast ("#" <> localDisplayName <> " " <> c <> "> ") "invited you to join the group"
|
||||
where
|
||||
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
|
||||
sameGroupLinkId (Just gli) (Just gli') = gli == gli'
|
||||
@ -5392,29 +5431,20 @@ getCreateActiveUser st testView = do
|
||||
getWithPrompt :: String -> IO String
|
||||
getWithPrompt s = putStr (s <> ": ") >> hFlush stdout >> getLine
|
||||
|
||||
whenUserNtfs :: ChatMonad' m => User -> m () -> m ()
|
||||
whenUserNtfs User {showNtfs, activeUser} = when $ showNtfs || activeUser
|
||||
userNtf :: User -> Bool
|
||||
userNtf User {showNtfs, activeUser} = showNtfs || activeUser
|
||||
|
||||
whenContactNtfs :: ChatMonad' m => User -> Contact -> m () -> m ()
|
||||
whenContactNtfs user Contact {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
|
||||
chatNtf :: User -> ChatInfo c -> Bool
|
||||
chatNtf user = \case
|
||||
DirectChat ct -> contactNtf user ct
|
||||
GroupChat g -> groupNtf user g
|
||||
_ -> False
|
||||
|
||||
whenGroupNtfs :: ChatMonad' m => User -> GroupInfo -> m () -> m ()
|
||||
whenGroupNtfs user GroupInfo {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
|
||||
contactNtf :: User -> Contact -> Bool
|
||||
contactNtf user Contact {chatSettings} = userNtf user && enableNtfs chatSettings
|
||||
|
||||
showMsgToast :: ChatMonad' m => Text -> MsgContent -> Maybe MarkdownList -> m ()
|
||||
showMsgToast from mc md_ = showToast from $ maybe (msgContentText mc) (mconcat . map hideSecret) md_
|
||||
where
|
||||
hideSecret :: FormattedText -> Text
|
||||
hideSecret FormattedText {format = Just Secret} = "..."
|
||||
hideSecret FormattedText {text} = text
|
||||
|
||||
showToast :: ChatMonad' m => Text -> Text -> m ()
|
||||
showToast title text = atomically . (`writeTBQueue` Notification {title, text}) =<< asks notifyQ
|
||||
|
||||
notificationSubscriber :: ChatMonad' m => m ()
|
||||
notificationSubscriber = do
|
||||
ChatController {notifyQ, sendNotification} <- ask
|
||||
forever $ atomically (readTBQueue notifyQ) >>= liftIO . sendNotification
|
||||
groupNtf :: User -> GroupInfo -> Bool
|
||||
groupNtf user GroupInfo {chatSettings} = userNtf user && enableNtfs chatSettings
|
||||
|
||||
withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
|
||||
withUser' action =
|
||||
@ -5633,6 +5663,7 @@ chatCommandP =
|
||||
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP),
|
||||
"/_contacts " *> (APIListContacts <$> A.decimal),
|
||||
"/contacts" $> ListContacts,
|
||||
"/_connect plan " *> (APIConnectPlan <$> A.decimal <* A.space <*> strP),
|
||||
"/_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),
|
||||
|
@ -34,8 +34,7 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.String
|
||||
import Data.Text (Text)
|
||||
import Data.Time (NominalDiffTime)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Time (NominalDiffTime, UTCTime)
|
||||
import Data.Version (showVersion)
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Haskell.TH (Exp, Q, runIO)
|
||||
@ -153,20 +152,10 @@ defaultInlineFilesConfig =
|
||||
receiveInstant = True -- allow receiving instant files, within receiveChunks limit
|
||||
}
|
||||
|
||||
data ActiveTo = ActiveNone | ActiveC ContactName | ActiveG GroupName
|
||||
deriving (Eq)
|
||||
|
||||
chatActiveTo :: ChatName -> ActiveTo
|
||||
chatActiveTo (ChatName cType name) = case cType of
|
||||
CTDirect -> ActiveC name
|
||||
CTGroup -> ActiveG name
|
||||
_ -> ActiveNone
|
||||
|
||||
data ChatDatabase = ChatDatabase {chatStore :: SQLiteStore, agentStore :: SQLiteStore}
|
||||
|
||||
data ChatController = ChatController
|
||||
{ currentUser :: TVar (Maybe User),
|
||||
activeTo :: TVar ActiveTo,
|
||||
firstTime :: Bool,
|
||||
smpAgent :: AgentClient,
|
||||
agentAsync :: TVar (Maybe (Async (), Maybe (Async ()))),
|
||||
@ -175,8 +164,6 @@ data ChatController = ChatController
|
||||
idsDrg :: TVar ChaChaDRG,
|
||||
inputQ :: TBQueue String,
|
||||
outputQ :: TBQueue (Maybe CorrId, ChatResponse),
|
||||
notifyQ :: TBQueue Notification,
|
||||
sendNotification :: Notification -> IO (),
|
||||
subscriptionMode :: TVar SubscriptionMode,
|
||||
chatLock :: Lock,
|
||||
sndFiles :: TVar (Map Int64 Handle),
|
||||
@ -338,6 +325,7 @@ data ChatCommand
|
||||
| APIAddContact UserId IncognitoEnabled
|
||||
| AddContact IncognitoEnabled
|
||||
| APISetConnectionIncognito Int64 IncognitoEnabled
|
||||
| APIConnectPlan UserId AConnectionRequestUri
|
||||
| APIConnect UserId IncognitoEnabled (Maybe AConnectionRequestUri)
|
||||
| Connect IncognitoEnabled (Maybe AConnectionRequestUri)
|
||||
| ConnectSimplex IncognitoEnabled -- UserId (not used in UI)
|
||||
@ -432,7 +420,7 @@ data ChatResponse
|
||||
| CRApiChats {user :: User, chats :: [AChat]}
|
||||
| CRChats {chats :: [AChat]}
|
||||
| CRApiChat {user :: User, chat :: AChat}
|
||||
| CRChatItems {user :: User, chatItems :: [AChatItem]}
|
||||
| CRChatItems {user :: User, chatName_ :: Maybe ChatName, chatItems :: [AChatItem]}
|
||||
| CRChatItemInfo {user :: User, chatItem :: AChatItem, chatItemInfo :: ChatItemInfo}
|
||||
| CRChatItemId User (Maybe ChatItemId)
|
||||
| CRApiParsedMarkdown {formattedText :: Maybe MarkdownList}
|
||||
@ -489,6 +477,7 @@ data ChatResponse
|
||||
| CRVersionInfo {versionInfo :: CoreVersionInfo, chatMigrations :: [UpMigration], agentMigrations :: [UpMigration]}
|
||||
| CRInvitation {user :: User, connReqInvitation :: ConnReqInvitation, connection :: PendingContactConnection}
|
||||
| CRConnectionIncognitoUpdated {user :: User, toConnection :: PendingContactConnection}
|
||||
| CRConnectionPlan {user :: User, connectionPlan :: ConnectionPlan}
|
||||
| CRSentConfirmation {user :: User}
|
||||
| CRSentInvitation {user :: User, customUserProfile :: Maybe Profile}
|
||||
| CRContactUpdated {user :: User, fromContact :: Contact, toContact :: Contact}
|
||||
@ -624,6 +613,64 @@ instance ToJSON ChatResponse where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR"
|
||||
|
||||
data ConnectionPlan
|
||||
= CPInvitationLink {invitationLinkPlan :: InvitationLinkPlan}
|
||||
| CPContactAddress {contactAddressPlan :: ContactAddressPlan}
|
||||
| CPGroupLink {groupLinkPlan :: GroupLinkPlan}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON ConnectionPlan where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CP"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CP"
|
||||
|
||||
data InvitationLinkPlan
|
||||
= ILPOk
|
||||
| ILPOwnLink
|
||||
| ILPConnecting {contact_ :: Maybe Contact}
|
||||
| ILPKnown {contact :: Contact}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON InvitationLinkPlan where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "ILP"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "ILP"
|
||||
|
||||
data ContactAddressPlan
|
||||
= CAPOk
|
||||
| CAPOwnLink
|
||||
| CAPConnecting {contact :: Contact}
|
||||
| CAPKnown {contact :: Contact}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON ContactAddressPlan where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CAP"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CAP"
|
||||
|
||||
data GroupLinkPlan
|
||||
= GLPOk
|
||||
| GLPOwnLink {groupInfo :: GroupInfo}
|
||||
| GLPConnecting {groupInfo_ :: Maybe GroupInfo}
|
||||
| GLPKnown {groupInfo :: GroupInfo}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON GroupLinkPlan where
|
||||
toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "GLP"
|
||||
toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "GLP"
|
||||
|
||||
connectionPlanOk :: ConnectionPlan -> Bool
|
||||
connectionPlanOk = \case
|
||||
CPInvitationLink ilp -> case ilp of
|
||||
ILPOk -> True
|
||||
ILPOwnLink -> True
|
||||
_ -> False
|
||||
CPContactAddress cap -> case cap of
|
||||
CAPOk -> True
|
||||
CAPOwnLink -> True
|
||||
_ -> False
|
||||
CPGroupLink glp -> case glp of
|
||||
GLPOk -> True
|
||||
GLPOwnLink _ -> True
|
||||
_ -> False
|
||||
|
||||
newtype UserPwd = UserPwd {unUserPwd :: Text}
|
||||
deriving (Eq, Show)
|
||||
|
||||
@ -888,6 +935,7 @@ data ChatErrorType
|
||||
| CEChatNotStarted
|
||||
| CEChatNotStopped
|
||||
| CEChatStoreChanged
|
||||
| CEConnectionPlan {connectionPlan :: ConnectionPlan}
|
||||
| CEInvalidConnReq
|
||||
| CEInvalidChatMessage {connection :: Connection, msgMeta :: Maybe MsgMetaJSON, messageData :: Text, message :: String}
|
||||
| CEContactNotFound {contactName :: ContactName, suspectedMember :: Maybe (GroupInfo, GroupMember)}
|
||||
@ -1013,14 +1061,6 @@ mkChatError = ChatError . CEException . show
|
||||
chatCmdError :: Maybe User -> String -> ChatResponse
|
||||
chatCmdError user = CRChatCmdError user . ChatError . CECommandError
|
||||
|
||||
setActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
setActive to = asks activeTo >>= atomically . (`writeTVar` to)
|
||||
|
||||
unsetActive :: (MonadUnliftIO m, MonadReader ChatController m) => ActiveTo -> m ()
|
||||
unsetActive a = asks activeTo >>= atomically . (`modifyTVar` unset)
|
||||
where
|
||||
unset a' = if a == a' then ActiveNone else a'
|
||||
|
||||
toView :: ChatMonad' m => ChatResponse -> m ()
|
||||
toView event = do
|
||||
q <- asks outputQ
|
||||
|
@ -14,8 +14,8 @@ import Simplex.Chat.Types
|
||||
import System.Exit (exitFailure)
|
||||
import UnliftIO.Async
|
||||
|
||||
simplexChatCore :: ChatConfig -> ChatOpts -> Maybe (Notification -> IO ()) -> (User -> ChatController -> IO ()) -> IO ()
|
||||
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} sendToast chat =
|
||||
simplexChatCore :: ChatConfig -> ChatOpts -> (User -> ChatController -> IO ()) -> IO ()
|
||||
simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {coreOptions = CoreChatOpts {dbFilePrefix, dbKey, logAgent}} chat =
|
||||
case logAgent of
|
||||
Just level -> do
|
||||
setLogLevel level
|
||||
@ -28,7 +28,7 @@ simplexChatCore cfg@ChatConfig {confirmMigrations, testView} opts@ChatOpts {core
|
||||
exitFailure
|
||||
run db@ChatDatabase {chatStore} = do
|
||||
u <- getCreateActiveUser chatStore testView
|
||||
cc <- newChatController db (Just u) cfg opts sendToast
|
||||
cc <- newChatController db (Just u) cfg opts
|
||||
runSimplexChat opts u cc chat
|
||||
|
||||
runSimplexChat :: ChatOpts -> User -> ChatController -> (User -> ChatController -> IO ()) -> IO ()
|
||||
|
@ -47,8 +47,10 @@ import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>))
|
||||
data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection
|
||||
deriving (Eq, Show, Ord, Generic)
|
||||
|
||||
data ChatName = ChatName ChatType Text
|
||||
deriving (Show)
|
||||
data ChatName = ChatName {chatType :: ChatType, chatName :: Text}
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance ToJSON ChatName where toEncoding = J.genericToEncoding J.defaultOptions
|
||||
|
||||
chatTypeStr :: ChatType -> String
|
||||
chatTypeStr = \case
|
||||
|
@ -0,0 +1,24 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash where
|
||||
|
||||
import Database.SQLite.Simple (Query)
|
||||
import Database.SQLite.Simple.QQ (sql)
|
||||
|
||||
m20231009_via_group_link_uri_hash :: Query
|
||||
m20231009_via_group_link_uri_hash =
|
||||
[sql|
|
||||
CREATE INDEX idx_connections_conn_req_inv ON connections(conn_req_inv);
|
||||
|
||||
ALTER TABLE groups ADD COLUMN via_group_link_uri_hash BLOB;
|
||||
CREATE INDEX idx_groups_via_group_link_uri_hash ON groups(via_group_link_uri_hash);
|
||||
|]
|
||||
|
||||
down_m20231009_via_group_link_uri_hash :: Query
|
||||
down_m20231009_via_group_link_uri_hash =
|
||||
[sql|
|
||||
DROP INDEX idx_groups_via_group_link_uri_hash;
|
||||
ALTER TABLE groups DROP COLUMN via_group_link_uri_hash;
|
||||
|
||||
DROP INDEX idx_connections_conn_req_inv;
|
||||
|]
|
@ -117,7 +117,8 @@ CREATE TABLE groups(
|
||||
unread_chat INTEGER DEFAULT 0 CHECK(unread_chat NOT NULL),
|
||||
chat_ts TEXT,
|
||||
favorite INTEGER NOT NULL DEFAULT 0,
|
||||
send_rcpts INTEGER, -- received
|
||||
send_rcpts INTEGER,
|
||||
via_group_link_uri_hash BLOB, -- received
|
||||
FOREIGN KEY(user_id, local_display_name)
|
||||
REFERENCES display_names(user_id, local_display_name)
|
||||
ON DELETE CASCADE
|
||||
@ -736,3 +737,7 @@ CREATE INDEX idx_received_probes_probe_hash ON received_probes(probe_hash);
|
||||
CREATE INDEX idx_sent_probes_created_at ON sent_probes(created_at);
|
||||
CREATE INDEX idx_sent_probe_hashes_created_at ON sent_probe_hashes(created_at);
|
||||
CREATE INDEX idx_received_probes_created_at ON received_probes(created_at);
|
||||
CREATE INDEX idx_connections_conn_req_inv ON connections(conn_req_inv);
|
||||
CREATE INDEX idx_groups_via_group_link_uri_hash ON groups(
|
||||
via_group_link_uri_hash
|
||||
);
|
||||
|
@ -196,7 +196,7 @@ chatMigrateInit dbFilePrefix dbKey confirm = runExceptT $ do
|
||||
where
|
||||
initialize st db = do
|
||||
user_ <- getActiveUser_ st
|
||||
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey) Nothing
|
||||
newChatController db user_ defaultMobileConfig (mobileChatOpts dbFilePrefix dbKey)
|
||||
migrate createStore dbFile confirmMigrations =
|
||||
ExceptT $
|
||||
(first (DBMErrorMigration dbFile) <$> createStore dbFile dbKey confirmMigrations)
|
||||
|
@ -7,6 +7,7 @@
|
||||
|
||||
module Simplex.Chat.Store.Connections
|
||||
( getConnectionEntity,
|
||||
getConnectionEntityByConnReq,
|
||||
getConnectionsToSubscribe,
|
||||
unsetConnectionToSubscribe,
|
||||
)
|
||||
@ -28,7 +29,7 @@ import Simplex.Chat.Protocol
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Chat.Types.Preferences
|
||||
import Simplex.Messaging.Agent.Protocol (ConnId)
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow')
|
||||
import Simplex.Messaging.Agent.Store.SQLite (firstRow, firstRow', maybeFirstRow)
|
||||
import qualified Simplex.Messaging.Agent.Store.SQLite.DB as DB
|
||||
import Simplex.Messaging.Util (eitherToMaybe)
|
||||
|
||||
@ -149,6 +150,12 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do
|
||||
userContact_ [(cReq, groupId)] = Right UserContact {userContactLinkId, connReqContact = cReq, groupId}
|
||||
userContact_ _ = Left SEUserContactLinkNotFound
|
||||
|
||||
getConnectionEntityByConnReq :: DB.Connection -> User -> ConnReqInvitation -> IO (Maybe ConnectionEntity)
|
||||
getConnectionEntityByConnReq db user cReq = do
|
||||
connId_ <- maybeFirstRow fromOnly $
|
||||
DB.query db "SELECT agent_conn_id FROM connections WHERE conn_req_inv = ? LIMIT 1" (Only cReq)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getConnectionEntity db user) connId_
|
||||
|
||||
getConnectionsToSubscribe :: DB.Connection -> IO ([ConnId], [ConnectionEntity])
|
||||
getConnectionsToSubscribe db = do
|
||||
aConnIds <- map fromOnly <$> DB.query_ db "SELECT agent_conn_id FROM connections where to_subscribe = 1"
|
||||
|
@ -22,6 +22,7 @@ module Simplex.Chat.Store.Direct
|
||||
createConnReqConnection,
|
||||
getProfileById,
|
||||
getConnReqContactXContactId,
|
||||
getContactByConnReqHash,
|
||||
createDirectContact,
|
||||
deleteContactConnectionsAndFiles,
|
||||
deleteContact,
|
||||
@ -132,32 +133,10 @@ createConnReqConnection db userId acId cReqHash xContactId incognitoProfile grou
|
||||
|
||||
getConnReqContactXContactId :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact, Maybe XContactId)
|
||||
getConnReqContactXContactId db user@User {userId} cReqHash = do
|
||||
getContact' >>= \case
|
||||
getContactByConnReqHash db user cReqHash >>= \case
|
||||
c@(Just _) -> pure (c, Nothing)
|
||||
Nothing -> (Nothing,) <$> getXContactId
|
||||
where
|
||||
getContact' :: IO (Maybe Contact)
|
||||
getContact' =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
|
||||
c.peer_chat_min_version, c.peer_chat_max_version
|
||||
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
|
||||
WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.deleted = 0
|
||||
ORDER BY c.created_at DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, cReqHash)
|
||||
getXContactId :: IO (Maybe XContactId)
|
||||
getXContactId =
|
||||
maybeFirstRow fromOnly $
|
||||
@ -166,6 +145,29 @@ getConnReqContactXContactId db user@User {userId} cReqHash = do
|
||||
"SELECT xcontact_id FROM connections WHERE user_id = ? AND via_contact_uri_hash = ? LIMIT 1"
|
||||
(userId, cReqHash)
|
||||
|
||||
getContactByConnReqHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe Contact)
|
||||
getContactByConnReqHash db user@User {userId} cReqHash =
|
||||
maybeFirstRow (toContact user) $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT
|
||||
-- Contact
|
||||
ct.contact_id, ct.contact_profile_id, ct.local_display_name, ct.via_group, cp.display_name, cp.full_name, cp.image, cp.contact_link, cp.local_alias, ct.contact_used, ct.contact_status, ct.enable_ntfs, ct.send_rcpts, ct.favorite,
|
||||
cp.preferences, ct.user_preferences, ct.created_at, ct.updated_at, ct.chat_ts, ct.contact_group_member_id, ct.contact_grp_inv_sent,
|
||||
-- Connection
|
||||
c.connection_id, c.agent_conn_id, c.conn_level, c.via_contact, c.via_user_contact_link, c.via_group_link, c.group_link_id, c.custom_user_profile_id, c.conn_status, c.conn_type, c.contact_conn_initiated, c.local_alias,
|
||||
c.contact_id, c.group_member_id, c.snd_file_id, c.rcv_file_id, c.user_contact_link_id, c.created_at, c.security_code, c.security_code_verified_at, c.auth_err_counter,
|
||||
c.peer_chat_min_version, c.peer_chat_max_version
|
||||
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
|
||||
WHERE ct.user_id = ? AND c.via_contact_uri_hash = ? AND ct.contact_status = ? AND ct.deleted = 0
|
||||
ORDER BY c.created_at DESC
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, cReqHash, CSActive)
|
||||
|
||||
createDirectConnection :: DB.Connection -> User -> ConnId -> ConnReqInvitation -> ConnStatus -> Maybe Profile -> SubscriptionMode -> IO PendingContactConnection
|
||||
createDirectConnection db User {userId} acId cReq pccConnStatus incognitoProfile subMode = do
|
||||
createdAt <- getCurrentTime
|
||||
|
@ -28,9 +28,12 @@ module Simplex.Chat.Store.Groups
|
||||
getGroupAndMember,
|
||||
createNewGroup,
|
||||
createGroupInvitation,
|
||||
setViaGroupLinkHash,
|
||||
setGroupInvitationChatItemId,
|
||||
getGroup,
|
||||
getGroupInfo,
|
||||
getGroupInfoByUserContactLinkConnReq,
|
||||
getGroupInfoByGroupLinkHash,
|
||||
updateGroupProfile,
|
||||
getGroupIdByName,
|
||||
getGroupMemberIdByName,
|
||||
@ -400,6 +403,17 @@ createContactMemberInv_ db User {userId, userContactId} groupId userOrContact Me
|
||||
)
|
||||
pure $ Right incognitoLdn
|
||||
|
||||
setViaGroupLinkHash :: DB.Connection -> GroupId -> Int64 -> IO ()
|
||||
setViaGroupLinkHash db groupId connId =
|
||||
DB.execute
|
||||
db
|
||||
[sql|
|
||||
UPDATE groups
|
||||
SET via_group_link_uri_hash = (SELECT via_contact_uri_hash FROM connections WHERE connection_id = ?)
|
||||
WHERE group_id = ?
|
||||
|]
|
||||
(connId, groupId)
|
||||
|
||||
setGroupInvitationChatItemId :: DB.Connection -> User -> GroupId -> ChatItemId -> IO ()
|
||||
setGroupInvitationChatItemId db User {userId} groupId chatItemId = do
|
||||
currentTs <- getCurrentTime
|
||||
@ -1097,6 +1111,35 @@ getGroupInfo db User {userId, userContactId} groupId =
|
||||
|]
|
||||
(groupId, userId, userContactId)
|
||||
|
||||
getGroupInfoByUserContactLinkConnReq :: DB.Connection -> User -> ConnReqContact -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByUserContactLinkConnReq db user cReq = do
|
||||
groupId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT group_id
|
||||
FROM user_contact_links
|
||||
WHERE conn_req_contact = ?
|
||||
|]
|
||||
(Only cReq)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
|
||||
getGroupInfoByGroupLinkHash :: DB.Connection -> User -> ConnReqUriHash -> IO (Maybe GroupInfo)
|
||||
getGroupInfoByGroupLinkHash db user@User {userId, userContactId} groupLinkHash = do
|
||||
groupId_ <- maybeFirstRow fromOnly $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT g.group_id
|
||||
FROM groups g
|
||||
JOIN group_members mu ON mu.group_id = g.group_id
|
||||
WHERE g.user_id = ? AND g.via_group_link_uri_hash = ?
|
||||
AND mu.contact_id = ? AND mu.member_status NOT IN (?,?,?)
|
||||
LIMIT 1
|
||||
|]
|
||||
(userId, groupLinkHash, userContactId, GSMemRemoved, GSMemLeft, GSMemGroupDeleted)
|
||||
maybe (pure Nothing) (fmap eitherToMaybe . runExceptT . getGroupInfo db user) groupId_
|
||||
|
||||
getGroupIdByName :: DB.Connection -> User -> GroupName -> ExceptT StoreError IO GroupId
|
||||
getGroupIdByName db User {userId} gName =
|
||||
ExceptT . firstRow fromOnly (SEGroupNotFoundByName gName) $
|
||||
|
@ -83,6 +83,7 @@ import Simplex.Chat.Migrations.M20230913_member_contacts
|
||||
import Simplex.Chat.Migrations.M20230914_member_probes
|
||||
import Simplex.Chat.Migrations.M20230926_contact_status
|
||||
import Simplex.Chat.Migrations.M20231002_conn_initiated
|
||||
import Simplex.Chat.Migrations.M20231009_via_group_link_uri_hash
|
||||
import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..))
|
||||
|
||||
schemaMigrations :: [(String, Query, Maybe Query)]
|
||||
@ -165,7 +166,8 @@ schemaMigrations =
|
||||
("20230913_member_contacts", m20230913_member_contacts, Just down_m20230913_member_contacts),
|
||||
("20230914_member_probes", m20230914_member_probes, Just down_m20230914_member_probes),
|
||||
("20230926_contact_status", m20230926_contact_status, Just down_m20230926_contact_status),
|
||||
("20231002_conn_initiated", m20231002_conn_initiated, Just down_m20231002_conn_initiated)
|
||||
("20231002_conn_initiated", m20231002_conn_initiated, Just down_m20231002_conn_initiated),
|
||||
("20231009_via_group_link_uri_hash", m20231009_via_group_link_uri_hash, Just down_m20231009_via_group_link_uri_hash)
|
||||
]
|
||||
|
||||
-- | The list of migrations in ascending order by date
|
||||
|
@ -40,6 +40,7 @@ module Simplex.Chat.Store.Profiles
|
||||
deleteUserAddress,
|
||||
getUserAddress,
|
||||
getUserContactLinkById,
|
||||
getUserContactLinkByConnReq,
|
||||
updateUserAddressAutoAccept,
|
||||
getProtocolServers,
|
||||
overwriteProtocolServers,
|
||||
@ -436,6 +437,18 @@ getUserContactLinkById db userId userContactLinkId =
|
||||
|]
|
||||
(userId, userContactLinkId)
|
||||
|
||||
getUserContactLinkByConnReq :: DB.Connection -> ConnReqContact -> IO (Maybe UserContactLink)
|
||||
getUserContactLinkByConnReq db cReq =
|
||||
maybeFirstRow toUserContactLink $
|
||||
DB.query
|
||||
db
|
||||
[sql|
|
||||
SELECT conn_req_contact, auto_accept, auto_accept_incognito, auto_reply_msg_content
|
||||
FROM user_contact_links
|
||||
WHERE conn_req_contact = ?
|
||||
|]
|
||||
(Only cReq)
|
||||
|
||||
updateUserAddressAutoAccept :: DB.Connection -> User -> Maybe AutoAccept -> ExceptT StoreError IO UserContactLink
|
||||
updateUserAddressAutoAccept db user@User {userId} autoAccept = do
|
||||
link <- getUserAddress db user
|
||||
|
@ -15,7 +15,6 @@ import Simplex.Chat.Core
|
||||
import Simplex.Chat.Help (chatWelcome)
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Terminal.Input
|
||||
import Simplex.Chat.Terminal.Notification
|
||||
import Simplex.Chat.Terminal.Output
|
||||
import Simplex.FileTransfer.Client.Presets (defaultXFTPServers)
|
||||
import Simplex.Messaging.Client (defaultNetworkConfig)
|
||||
@ -40,10 +39,9 @@ terminalChatConfig =
|
||||
}
|
||||
|
||||
simplexChatTerminal :: WithTerminal t => ChatConfig -> ChatOpts -> t -> IO ()
|
||||
simplexChatTerminal cfg opts t = do
|
||||
sendToast <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
|
||||
handle checkDBKeyError . simplexChatCore cfg opts sendToast $ \u cc -> do
|
||||
ct <- newChatTerminal t
|
||||
simplexChatTerminal cfg opts t =
|
||||
handle checkDBKeyError . simplexChatCore cfg opts $ \u cc -> do
|
||||
ct <- newChatTerminal t opts
|
||||
when (firstTime cc) . printToTerminal ct $ chatWelcome u
|
||||
runChatTerminal ct cc
|
||||
|
||||
|
@ -56,14 +56,26 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do
|
||||
cmd = parseChatCommand bs
|
||||
unless (isMessage cmd) $ echo s
|
||||
r <- runReaderT (execChatCommand bs) cc
|
||||
case r of
|
||||
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRChatError _ _ -> when (isMessage cmd) $ echo s
|
||||
_ -> pure ()
|
||||
processResp s cmd r
|
||||
printRespToTerminal ct cc False r
|
||||
startLiveMessage cmd r
|
||||
where
|
||||
echo s = printToTerminal ct [plain s]
|
||||
processResp s cmd = \case
|
||||
CRActiveUser _ -> setActive ct ""
|
||||
CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_
|
||||
CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo
|
||||
CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c
|
||||
CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g
|
||||
CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g
|
||||
CRChatCmdError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRChatError _ _ -> when (isMessage cmd) $ echo s
|
||||
CRCmdOk _ -> case cmd of
|
||||
Right APIDeleteUser {} -> setActive ct ""
|
||||
_ -> pure ()
|
||||
_ -> pure ()
|
||||
isMessage = \case
|
||||
Right SendMessage {} -> True
|
||||
Right SendLiveMessage {} -> True
|
||||
@ -133,7 +145,7 @@ runTerminalInput ct cc = withChatTerm ct $ do
|
||||
receiveFromTTY cc ct
|
||||
|
||||
receiveFromTTY :: forall m. MonadTerminal m => ChatController -> ChatTerminal -> m ()
|
||||
receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState} =
|
||||
receiveFromTTY cc@ChatController {inputQ, currentUser, chatStore} ct@ChatTerminal {termSize, termState, liveMessageState, activeTo} =
|
||||
forever $ getKey >>= liftIO . processKey >> withTermLock ct (updateInput ct)
|
||||
where
|
||||
processKey :: (Key, Modifiers) -> IO ()
|
||||
@ -152,11 +164,11 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C
|
||||
when (inputString ts /= "" || isLive) $
|
||||
atomically (submitInput live ts) >>= mapM_ (uncurry endLiveMessage)
|
||||
update key = do
|
||||
ac <- readTVarIO activeTo
|
||||
chatPrefix <- readTVarIO activeTo
|
||||
live <- isJust <$> readTVarIO liveMessageState
|
||||
ts <- readTVarIO termState
|
||||
user_ <- readTVarIO currentUser
|
||||
ts' <- updateTermState user_ chatStore ac live (width termSize) key ts
|
||||
ts' <- updateTermState user_ chatStore chatPrefix live (width termSize) key ts
|
||||
atomically $ writeTVar termState $! ts'
|
||||
|
||||
endLiveMessage :: String -> LiveMessage -> IO ()
|
||||
@ -202,8 +214,8 @@ data AutoComplete
|
||||
| ACCommand Text
|
||||
| ACNone
|
||||
|
||||
updateTermState :: Maybe User -> SQLiteStore -> ActiveTo -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
|
||||
updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
|
||||
updateTermState :: Maybe User -> SQLiteStore -> String -> Bool -> Int -> (Key, Modifiers) -> TerminalState -> IO TerminalState
|
||||
updateTermState user_ st chatPrefix live tw (key, ms) ts@TerminalState {inputString = s, inputPosition = p, autoComplete = acp} = case key of
|
||||
CharKey c
|
||||
| ms == mempty || ms == shiftKey -> pure $ insertChars $ charsWithContact [c]
|
||||
| ms == altKey && c == 'b' -> pure $ setPosition prevWordPos
|
||||
@ -325,17 +337,13 @@ updateTermState user_ st ac live tw (key, ms) ts@TerminalState {inputString = s,
|
||||
charsWithContact cs
|
||||
| live = cs
|
||||
| null s && cs /= "@" && cs /= "#" && cs /= "/" && cs /= ">" && cs /= "\\" && cs /= "!" && cs /= "+" && cs /= "-" =
|
||||
contactPrefix <> cs
|
||||
chatPrefix <> cs
|
||||
| (s == ">" || s == "\\" || s == "!") && cs == " " =
|
||||
cs <> contactPrefix
|
||||
cs <> chatPrefix
|
||||
| otherwise = cs
|
||||
insertChars = ts' . if p >= length s then append else insert
|
||||
append cs = let s' = s <> cs in (s', length s')
|
||||
insert cs = let (b, a) = splitAt p s in (b <> cs <> a, p + length cs)
|
||||
contactPrefix = case ac of
|
||||
ActiveNone -> ""
|
||||
ActiveC c -> "@" <> T.unpack c <> " "
|
||||
ActiveG g -> "#" <> T.unpack g <> " "
|
||||
backDeleteChar
|
||||
| p == 0 || null s = ts
|
||||
| p >= length s = ts' (init s, length s - 1)
|
||||
|
@ -13,13 +13,14 @@ import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Simplex.Chat.Types
|
||||
import Simplex.Messaging.Util (catchAll_)
|
||||
import System.Directory (createDirectoryIfMissing, doesFileExist, findExecutable, getAppUserDataDirectory)
|
||||
import System.FilePath (combine)
|
||||
import System.Info (os)
|
||||
import System.Process (readCreateProcess, shell)
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
initializeNotifications :: IO (Notification -> IO ())
|
||||
initializeNotifications =
|
||||
hideException <$> case os of
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
@ -13,13 +14,24 @@ import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Data.List (intercalate)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.LocalTime (getCurrentTimeZone)
|
||||
import Simplex.Chat (processChatCommand)
|
||||
import Simplex.Chat (processChatCommand, chatNtf, contactNtf, groupNtf, userNtf)
|
||||
import Simplex.Chat.Controller
|
||||
import Simplex.Chat.Messages hiding (NewChatItem (..))
|
||||
import Simplex.Chat.Markdown
|
||||
import Simplex.Chat.Messages
|
||||
import Simplex.Chat.Messages.CIContent (CIContent(..), SMsgDirection (..))
|
||||
import Simplex.Chat.Options
|
||||
import Simplex.Chat.Protocol (MsgContent (..), msgContentText)
|
||||
import Simplex.Chat.Styled
|
||||
import Simplex.Chat.Terminal.Notification (Notification (..), initializeNotifications)
|
||||
import Simplex.Chat.Types (Contact, GroupInfo (..), User (..), UserContactRequest (..))
|
||||
import Simplex.Chat.View
|
||||
import Simplex.Messaging.Agent.Protocol
|
||||
import Simplex.Messaging.Encoding.String
|
||||
import Simplex.Messaging.Util (safeDecodeUtf8)
|
||||
import System.Console.ANSI.Types
|
||||
import System.IO (IOMode (..), hPutStrLn, withFile)
|
||||
import System.Mem.Weak (Weak)
|
||||
@ -33,7 +45,9 @@ data ChatTerminal = ChatTerminal
|
||||
termSize :: Size,
|
||||
liveMessageState :: TVar (Maybe LiveMessage),
|
||||
nextMessageRow :: TVar Int,
|
||||
termLock :: TMVar ()
|
||||
termLock :: TMVar (),
|
||||
sendNotification :: Maybe (Notification -> IO ()),
|
||||
activeTo :: TVar String
|
||||
}
|
||||
|
||||
data TerminalState = TerminalState
|
||||
@ -78,16 +92,28 @@ instance WithTerminal VirtualTerminal where
|
||||
withChatTerm :: (MonadIO m, MonadMask m) => ChatTerminal -> (forall t. WithTerminal t => TerminalT t m a) -> m a
|
||||
withChatTerm ChatTerminal {termDevice = TerminalDevice t} action = withTerm t $ runTerminalT action
|
||||
|
||||
newChatTerminal :: WithTerminal t => t -> IO ChatTerminal
|
||||
newChatTerminal t = do
|
||||
newChatTerminal :: WithTerminal t => t -> ChatOpts -> IO ChatTerminal
|
||||
newChatTerminal t opts = do
|
||||
termSize <- withTerm t . runTerminalT $ getWindowSize
|
||||
let lastRow = height termSize - 1
|
||||
termState <- newTVarIO mkTermState
|
||||
liveMessageState <- newTVarIO Nothing
|
||||
termLock <- newTMVarIO ()
|
||||
nextMessageRow <- newTVarIO lastRow
|
||||
sendNotification <- if muteNotifications opts then pure Nothing else Just <$> initializeNotifications
|
||||
activeTo <- newTVarIO ""
|
||||
-- threadDelay 500000 -- this delay is the same as timeout in getTerminalSize
|
||||
return ChatTerminal {termDevice = TerminalDevice t, termState, termSize, liveMessageState, nextMessageRow, termLock}
|
||||
pure
|
||||
ChatTerminal
|
||||
{ termDevice = TerminalDevice t,
|
||||
termState,
|
||||
termSize,
|
||||
liveMessageState,
|
||||
nextMessageRow,
|
||||
termLock,
|
||||
sendNotification,
|
||||
activeTo
|
||||
}
|
||||
|
||||
mkTermState :: TerminalState
|
||||
mkTermState =
|
||||
@ -121,6 +147,7 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
||||
_ -> printToTerminal ct
|
||||
liveItems <- readTVarIO showLiveItems
|
||||
responseString cc liveItems r >>= printResp
|
||||
responseNotification ct cc r
|
||||
where
|
||||
markChatItemRead (AChatItem _ _ chat item@ChatItem {chatDir, meta = CIMeta {itemStatus}}) =
|
||||
case (muted chat chatDir, itemStatus) of
|
||||
@ -131,6 +158,100 @@ runTerminalOutput ct cc@ChatController {outputQ, showLiveItems, logFilePath} = d
|
||||
_ -> pure ()
|
||||
logResponse path s = withFile path AppendMode $ \h -> mapM_ (hPutStrLn h . unStyle) s
|
||||
|
||||
responseNotification :: ChatTerminal -> ChatController -> ChatResponse -> IO ()
|
||||
responseNotification t@ChatTerminal {sendNotification} cc = \case
|
||||
CRNewChatItem u (AChatItem _ SMDRcv cInfo ChatItem {chatDir, content = CIRcvMsgContent mc, formattedText}) ->
|
||||
when (chatNtf u cInfo) $ do
|
||||
whenCurrUser cc u $ setActiveChat t cInfo
|
||||
case (cInfo, chatDir) of
|
||||
(DirectChat ct, _) -> sendNtf (viewContactName ct <> "> ", text)
|
||||
(GroupChat g, CIGroupRcv m) -> sendNtf (fromGroup_ g m, text)
|
||||
_ -> pure ()
|
||||
where
|
||||
text = msgText mc formattedText
|
||||
CRChatItemUpdated u (AChatItem _ SMDRcv cInfo ChatItem {content = CIRcvMsgContent _}) ->
|
||||
whenCurrUser cc u $ when (chatNtf u cInfo) $ setActiveChat t cInfo
|
||||
CRContactConnected u ct _ -> when (contactNtf u ct) $ do
|
||||
whenCurrUser cc u $ setActiveContact t ct
|
||||
sendNtf (viewContactName ct <> "> ", "connected")
|
||||
CRContactAnotherClient u ct -> do
|
||||
whenCurrUser cc u $ unsetActiveContact t ct
|
||||
when (contactNtf u ct) $ sendNtf (viewContactName ct <> "> ", "connected to another client")
|
||||
CRContactsDisconnected srv _ -> serverNtf srv "disconnected"
|
||||
CRContactsSubscribed srv _ -> serverNtf srv "connected"
|
||||
CRReceivedGroupInvitation u g ct _ _ ->
|
||||
when (contactNtf u ct) $
|
||||
sendNtf ("#" <> viewGroupName g <> " " <> viewContactName ct <> "> ", "invited you to join the group")
|
||||
CRUserJoinedGroup u g _ -> when (groupNtf u g) $ do
|
||||
whenCurrUser cc u $ setActiveGroup t g
|
||||
sendNtf ("#" <> viewGroupName g, "you are connected to group")
|
||||
CRJoinedGroupMember u g m ->
|
||||
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
|
||||
CRConnectedToGroupMember u g m _ ->
|
||||
when (groupNtf u g) $ sendNtf ("#" <> viewGroupName g, "member " <> viewMemberName m <> " is connected")
|
||||
CRReceivedContactRequest u UserContactRequest {localDisplayName = n} ->
|
||||
when (userNtf u) $ sendNtf (viewName n <> ">", "wants to connect to you")
|
||||
_ -> pure ()
|
||||
where
|
||||
sendNtf = maybe (\_ -> pure ()) (. uncurry Notification) sendNotification
|
||||
serverNtf (SMPServer host _ _) str = sendNtf ("server " <> str, safeDecodeUtf8 $ strEncode host)
|
||||
|
||||
msgText :: MsgContent -> Maybe MarkdownList -> Text
|
||||
msgText (MCFile _) _ = "wants to send a file"
|
||||
msgText mc md_ = maybe (msgContentText mc) (mconcat . map hideSecret) md_
|
||||
where
|
||||
hideSecret :: FormattedText -> Text
|
||||
hideSecret FormattedText {format = Just Secret} = "..."
|
||||
hideSecret FormattedText {text} = text
|
||||
|
||||
chatActiveTo :: ChatName -> String
|
||||
chatActiveTo (ChatName cType name) = case cType of
|
||||
CTDirect -> T.unpack $ "@" <> viewName name <> " "
|
||||
CTGroup -> T.unpack $ "#" <> viewName name <> " "
|
||||
_ -> ""
|
||||
|
||||
chatInfoActiveTo :: ChatInfo c -> String
|
||||
chatInfoActiveTo = \case
|
||||
DirectChat c -> contactActiveTo c
|
||||
GroupChat g -> groupActiveTo g
|
||||
_ -> ""
|
||||
|
||||
contactActiveTo :: Contact -> String
|
||||
contactActiveTo c = T.unpack $ "@" <> viewContactName c <> " "
|
||||
|
||||
groupActiveTo :: GroupInfo -> String
|
||||
groupActiveTo g = T.unpack $ "#" <> viewGroupName g <> " "
|
||||
|
||||
setActiveChat :: ChatTerminal -> ChatInfo c -> IO ()
|
||||
setActiveChat t = setActive t . chatInfoActiveTo
|
||||
|
||||
setActiveContact :: ChatTerminal -> Contact -> IO ()
|
||||
setActiveContact t = setActive t . contactActiveTo
|
||||
|
||||
setActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
|
||||
setActiveGroup t = setActive t . groupActiveTo
|
||||
|
||||
setActive :: ChatTerminal -> String -> IO ()
|
||||
setActive ChatTerminal {activeTo} to = atomically $ writeTVar activeTo to
|
||||
|
||||
unsetActiveContact :: ChatTerminal -> Contact -> IO ()
|
||||
unsetActiveContact t = unsetActive t . contactActiveTo
|
||||
|
||||
unsetActiveGroup :: ChatTerminal -> GroupInfo -> IO ()
|
||||
unsetActiveGroup t = unsetActive t . groupActiveTo
|
||||
|
||||
unsetActive :: ChatTerminal -> String -> IO ()
|
||||
unsetActive ChatTerminal {activeTo} to' = atomically $ modifyTVar activeTo unset
|
||||
where
|
||||
unset to = if to == to' then "" else to
|
||||
|
||||
whenCurrUser :: ChatController -> User -> IO () -> IO ()
|
||||
whenCurrUser cc u a = do
|
||||
u_ <- readTVarIO $ currentUser cc
|
||||
when (sameUser u u_) a
|
||||
where
|
||||
sameUser User {userId = uId} = maybe False $ \User {userId} -> userId == uId
|
||||
|
||||
printRespToTerminal :: ChatTerminal -> ChatController -> Bool -> ChatResponse -> IO ()
|
||||
printRespToTerminal ct cc liveItems r = responseString cc liveItems r >>= printToTerminal ct
|
||||
|
||||
|
@ -204,6 +204,9 @@ directOrUsed ct@Contact {contactUsed} =
|
||||
anyDirectOrUsed :: Contact -> Bool
|
||||
anyDirectOrUsed Contact {contactUsed, activeConn = Connection {connLevel}} = connLevel == 0 || contactUsed
|
||||
|
||||
contactReady :: Contact -> Bool
|
||||
contactReady Contact {activeConn} = connReady activeConn
|
||||
|
||||
contactActive :: Contact -> Bool
|
||||
contactActive Contact {contactStatus} = contactStatus == CSActive
|
||||
|
||||
@ -1242,6 +1245,9 @@ data Connection = Connection
|
||||
}
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
connReady :: Connection -> Bool
|
||||
connReady Connection {connStatus} = connStatus == ConnReady || connStatus == ConnSndReady
|
||||
|
||||
authErrDisableCount :: Int
|
||||
authErrDisableCount = 10
|
||||
|
||||
@ -1416,8 +1422,6 @@ serializeIntroStatus = \case
|
||||
GMIntroToConnected -> "to-con"
|
||||
GMIntroConnected -> "con"
|
||||
|
||||
data Notification = Notification {title :: Text, text :: Text}
|
||||
|
||||
textParseJSON :: TextEncoding a => String -> J.Value -> JT.Parser a
|
||||
textParseJSON name = J.withText name $ maybe (fail $ "bad " <> name) pure . textDecode
|
||||
|
||||
|
@ -102,7 +102,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||
CRContactCode u ct code -> ttyUser u $ viewContactCode ct code testView
|
||||
CRGroupMemberCode u g m code -> ttyUser u $ viewGroupMemberCode g m code testView
|
||||
CRNewChatItem u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewChatItem chat item False ts tz <> viewItemReactions item
|
||||
CRChatItems u chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
||||
CRChatItems u _ chatItems -> ttyUser u $ concatMap (\(AChatItem _ _ chat item) -> viewChatItem chat item True ts tz <> viewItemReactions item) chatItems
|
||||
CRChatItemInfo u ci ciInfo -> ttyUser u $ viewChatItemInfo ci ciInfo tz
|
||||
CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
|
||||
CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts
|
||||
@ -147,6 +147,7 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView
|
||||
CRVersionInfo info _ _ -> viewVersionInfo logLevel info
|
||||
CRInvitation u cReq _ -> ttyUser u $ viewConnReqInvitation cReq
|
||||
CRConnectionIncognitoUpdated u c -> ttyUser u $ viewConnectionIncognitoUpdated c
|
||||
CRConnectionPlan u connectionPlan -> ttyUser u $ viewConnectionPlan connectionPlan
|
||||
CRSentConfirmation u -> ttyUser u ["confirmation sent!"]
|
||||
CRSentInvitation u customUserProfile -> ttyUser u $ viewSentInvitation customUserProfile testView
|
||||
CRContactDeleted u c -> ttyUser u [ttyContact' c <> ": contact is deleted"]
|
||||
@ -1218,6 +1219,41 @@ viewConnectionIncognitoUpdated PendingContactConnection {pccConnId, customUserPr
|
||||
| isJust customUserProfileId = ["connection " <> sShow pccConnId <> " changed to incognito"]
|
||||
| otherwise = ["connection " <> sShow pccConnId <> " changed to non incognito"]
|
||||
|
||||
viewConnectionPlan :: ConnectionPlan -> [StyledString]
|
||||
viewConnectionPlan = \case
|
||||
CPInvitationLink ilp -> case ilp of
|
||||
ILPOk -> [invLink "ok to connect"]
|
||||
ILPOwnLink -> [invLink "own link"]
|
||||
ILPConnecting Nothing -> [invLink "connecting"]
|
||||
ILPConnecting (Just ct) -> [invLink ("connecting to contact " <> ttyContact' ct)]
|
||||
ILPKnown ct ->
|
||||
[ invLink ("known contact " <> ttyContact' ct),
|
||||
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
where
|
||||
invLink = ("invitation link: " <>)
|
||||
CPContactAddress cap -> case cap of
|
||||
CAPOk -> [ctAddr "ok to connect"]
|
||||
CAPOwnLink -> [ctAddr "own address"]
|
||||
CAPConnecting ct -> [ctAddr ("connecting to contact " <> ttyContact' ct)]
|
||||
CAPKnown ct ->
|
||||
[ ctAddr ("known contact " <> ttyContact' ct),
|
||||
"use " <> ttyToContact' ct <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
where
|
||||
ctAddr = ("contact address: " <>)
|
||||
CPGroupLink glp -> case glp of
|
||||
GLPOk -> [grpLink "ok to connect"]
|
||||
GLPOwnLink g -> [grpLink "own link for group " <> ttyGroup' g]
|
||||
GLPConnecting Nothing -> [grpLink "connecting"]
|
||||
GLPConnecting (Just g) -> [grpLink ("connecting to group " <> ttyGroup' g)]
|
||||
GLPKnown g ->
|
||||
[ grpLink ("known group " <> ttyGroup' g),
|
||||
"use " <> ttyToGroup g <> highlight' "<message>" <> " to send messages"
|
||||
]
|
||||
where
|
||||
grpLink = ("group link: " <>)
|
||||
|
||||
viewContactUpdated :: Contact -> Contact -> [StyledString]
|
||||
viewContactUpdated
|
||||
Contact {localDisplayName = n, profile = LocalProfile {fullName, contactLink}}
|
||||
@ -1559,6 +1595,7 @@ viewChatError logLevel = \case
|
||||
CEChatNotStarted -> ["error: chat not started"]
|
||||
CEChatNotStopped -> ["error: chat not stopped"]
|
||||
CEChatStoreChanged -> ["error: chat store changed, please restart chat"]
|
||||
CEConnectionPlan connectionPlan -> viewConnectionPlan connectionPlan
|
||||
CEInvalidConnReq -> viewInvalidConnReq
|
||||
CEInvalidChatMessage Connection {connId} msgMeta_ msg e ->
|
||||
[ plain $
|
||||
|
@ -25,7 +25,7 @@ withBroadcastBot :: BroadcastBotOpts -> IO () -> IO ()
|
||||
withBroadcastBot opts test =
|
||||
bracket (forkIO bot) killThread (\_ -> threadDelay 500000 >> test)
|
||||
where
|
||||
bot = simplexChatCore testCfg (mkChatOpts opts) Nothing $ broadcastBot opts
|
||||
bot = simplexChatCore testCfg (mkChatOpts opts) $ broadcastBot opts
|
||||
|
||||
broadcastBotProfile :: Profile
|
||||
broadcastBotProfile = Profile {displayName = "broadcast_bot", fullName = "Broadcast Bot", image = Nothing, contactLink = Nothing, preferences = Nothing}
|
||||
|
@ -826,7 +826,7 @@ runDirectory cfg opts@DirectoryOpts {directoryLog} action = do
|
||||
threadDelay 500000
|
||||
action `finally` (mapM_ hClose (directoryLogFile st) >> killThread t)
|
||||
where
|
||||
bot st = simplexChatCore cfg (mkChatOpts opts) Nothing $ directoryService st opts
|
||||
bot st = simplexChatCore cfg (mkChatOpts opts) $ directoryService st opts
|
||||
|
||||
registerGroup :: TestCC -> TestCC -> String -> String -> IO ()
|
||||
registerGroup su u n fn = registerGroupId su u n fn 1 1
|
||||
|
@ -158,8 +158,8 @@ startTestChat tmp cfg opts@ChatOpts {coreOptions = CoreChatOpts {dbKey}} dbPrefi
|
||||
startTestChat_ :: ChatDatabase -> ChatConfig -> ChatOpts -> User -> IO TestCC
|
||||
startTestChat_ db cfg opts user = do
|
||||
t <- withVirtualTerminal termSettings pure
|
||||
ct <- newChatTerminal t
|
||||
cc <- newChatController db (Just user) cfg opts Nothing -- no notifications
|
||||
ct <- newChatTerminal t opts
|
||||
cc <- newChatController db (Just user) cfg opts
|
||||
chatAsync <- async . runSimplexChat opts user cc . const $ runChatTerminal ct
|
||||
atomically . unless (maintenance opts) $ readTVar (agentAsync cc) >>= \a -> when (isNothing a) retry
|
||||
termQ <- newTQueueIO
|
||||
|
@ -44,6 +44,10 @@ chatDirectTests = do
|
||||
describe "duplicate contacts" $ do
|
||||
it "duplicate contacts are separate (contacts don't merge)" testDuplicateContactsSeparate
|
||||
it "new contact is separate with multiple duplicate contacts (contacts don't merge)" testDuplicateContactsMultipleSeparate
|
||||
describe "invitation link connection plan" $ do
|
||||
it "invitation link ok to connect" testPlanInvitationLinkOk
|
||||
it "own invitation link" testPlanInvitationLinkOwn
|
||||
it "connecting via invitation link" testPlanInvitationLinkConnecting
|
||||
describe "SMP servers" $ do
|
||||
it "get and set SMP servers" testGetSetSMPServers
|
||||
it "test SMP server connection" testTestSMPServerConnection
|
||||
@ -236,6 +240,69 @@ testDuplicateContactsMultipleSeparate =
|
||||
alice `hasContactProfiles` ["alice", "bob", "bob", "bob"]
|
||||
bob `hasContactProfiles` ["bob", "alice", "alice", "alice"]
|
||||
|
||||
testPlanInvitationLinkOk :: HasCallStack => FilePath -> IO ()
|
||||
testPlanInvitationLinkOk =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/c"
|
||||
inv <- getInvitation alice
|
||||
bob ##> ("/_connect plan 1 " <> inv)
|
||||
bob <## "invitation link: ok to connect"
|
||||
|
||||
bob ##> ("/c " <> inv)
|
||||
bob <## "confirmation sent!"
|
||||
concurrently_
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> inv)
|
||||
bob <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||
|
||||
alice <##> bob
|
||||
|
||||
testPlanInvitationLinkOwn :: HasCallStack => FilePath -> IO ()
|
||||
testPlanInvitationLinkOwn tmp =
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/c"
|
||||
inv <- getInvitation alice
|
||||
alice ##> ("/_connect plan 1 " <> inv)
|
||||
alice <## "invitation link: own link"
|
||||
|
||||
alice ##> ("/c " <> inv)
|
||||
alice <## "confirmation sent!"
|
||||
alice
|
||||
<### [ "alice_1 (Alice): contact is connected",
|
||||
"alice_2 (Alice): contact is connected"
|
||||
]
|
||||
|
||||
alice ##> ("/_connect plan 1 " <> inv)
|
||||
alice <## "invitation link: ok to connect" -- conn_req_inv is forgotten after connection
|
||||
|
||||
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
|
||||
alice `send` "@alice_2 hi"
|
||||
alice
|
||||
<### [ WithTime "@alice_2 hi",
|
||||
WithTime "alice_1> hi"
|
||||
]
|
||||
alice `send` "@alice_1 hey"
|
||||
alice
|
||||
<### [ WithTime "@alice_1 hey",
|
||||
WithTime "alice_2> hey"
|
||||
]
|
||||
alice @@@ [("@alice_1", "hey"), ("@alice_2", "hey")]
|
||||
|
||||
testPlanInvitationLinkConnecting :: HasCallStack => FilePath -> IO ()
|
||||
testPlanInvitationLinkConnecting tmp = do
|
||||
inv <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/c"
|
||||
getInvitation alice
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
bob ##> ("/c " <> inv)
|
||||
bob <## "confirmation sent!"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> inv)
|
||||
bob <## "invitation link: connecting"
|
||||
|
||||
testContactClear :: HasCallStack => FilePath -> IO ()
|
||||
testContactClear =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
|
@ -57,6 +57,12 @@ chatGroupTests = do
|
||||
it "leaving groups with unused host contacts deletes incognito profiles" testGroupLinkIncognitoUnusedHostContactsDeleted
|
||||
it "group link member role" testGroupLinkMemberRole
|
||||
it "leaving and deleting the group joined via link should NOT delete previously existing direct contacts" testGroupLinkLeaveDelete
|
||||
describe "group link connection plan" $ do
|
||||
it "group link ok to connect; known group" testPlanGroupLinkOkKnown
|
||||
it "group is known if host contact was deleted" testPlanHostContactDeletedGroupLinkKnown
|
||||
it "own group link" testPlanGroupLinkOwn
|
||||
it "connecting via group link" testPlanGroupLinkConnecting
|
||||
it "re-join existing group after leaving" testPlanGroupLinkLeaveRejoin
|
||||
describe "group message errors" $ do
|
||||
it "show message decryption error" testGroupMsgDecryptError
|
||||
it "should report ratchet de-synchronization, synchronize ratchets" testGroupSyncRatchet
|
||||
@ -2251,6 +2257,237 @@ testGroupLinkLeaveDelete =
|
||||
bob <## "alice (Alice)"
|
||||
bob <## "cath (Catherine)"
|
||||
|
||||
testPlanGroupLinkOkKnown :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkOkKnown =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
alice ##> "/create link #team"
|
||||
gLink <- getGroupLink alice "team" GRMember True
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: ok to connect"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "connection request sent!"
|
||||
alice <## "bob (Bob): accepting request to join group #team..."
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "bob (Bob): contact is connected"
|
||||
alice <## "bob invited to group #team via your group link"
|
||||
alice <## "#team: bob joined the group",
|
||||
do
|
||||
bob <## "alice (Alice): contact is connected"
|
||||
bob <## "#team: you joined the group"
|
||||
]
|
||||
alice #> "#team hi"
|
||||
bob <# "#team alice> hi"
|
||||
bob #> "#team hey"
|
||||
alice <# "#team bob> hey"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
testPlanHostContactDeletedGroupLinkKnown :: HasCallStack => FilePath -> IO ()
|
||||
testPlanHostContactDeletedGroupLinkKnown =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
alice ##> "/create link #team"
|
||||
gLink <- getGroupLink alice "team" GRMember True
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "connection request sent!"
|
||||
alice <## "bob (Bob): accepting request to join group #team..."
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "bob (Bob): contact is connected"
|
||||
alice <## "bob invited to group #team via your group link"
|
||||
alice <## "#team: bob joined the group",
|
||||
do
|
||||
bob <## "alice (Alice): contact is connected"
|
||||
bob <## "#team: you joined the group"
|
||||
]
|
||||
alice #> "#team hi"
|
||||
bob <# "#team alice> hi"
|
||||
bob #> "#team hey"
|
||||
alice <# "#team bob> hey"
|
||||
|
||||
alice <##> bob
|
||||
threadDelay 500000
|
||||
bob ##> "/d alice"
|
||||
bob <## "alice: contact is deleted"
|
||||
alice <## "bob (Bob) deleted contact with you"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
testPlanGroupLinkOwn :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkOwn tmp =
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
alice ##> "/create link #team"
|
||||
gLink <- getGroupLink alice "team" GRMember True
|
||||
|
||||
alice ##> ("/_connect plan 1 " <> gLink)
|
||||
alice <## "group link: own link for group #team"
|
||||
|
||||
alice ##> ("/c " <> gLink)
|
||||
alice <## "connection request sent!"
|
||||
alice <## "alice_1 (Alice): accepting request to join group #team..."
|
||||
alice
|
||||
<### [ "alice_1 (Alice): contact is connected",
|
||||
"alice_1 invited to group #team via your group link",
|
||||
"#team: alice_1 joined the group",
|
||||
"alice_2 (Alice): contact is connected",
|
||||
"#team_1: you joined the group",
|
||||
"contact alice_2 is merged into alice_1",
|
||||
"use @alice_1 <message> to send messages"
|
||||
]
|
||||
alice `send` "#team 1"
|
||||
alice
|
||||
<### [ WithTime "#team 1",
|
||||
WithTime "#team_1 alice_1> 1"
|
||||
]
|
||||
alice `send` "#team_1 2"
|
||||
alice
|
||||
<### [ WithTime "#team_1 2",
|
||||
WithTime "#team alice_1> 2"
|
||||
]
|
||||
|
||||
alice ##> ("/_connect plan 1 " <> gLink)
|
||||
alice <## "group link: own link for group #team"
|
||||
|
||||
-- group works if merged contact is deleted
|
||||
alice ##> "/d alice_1"
|
||||
alice <## "alice_1: contact is deleted"
|
||||
|
||||
alice `send` "#team 3"
|
||||
alice
|
||||
<### [ WithTime "#team 3",
|
||||
WithTime "#team_1 alice_1> 3"
|
||||
]
|
||||
alice `send` "#team_1 4"
|
||||
alice
|
||||
<### [ WithTime "#team_1 4",
|
||||
WithTime "#team alice_1> 4"
|
||||
]
|
||||
|
||||
testPlanGroupLinkConnecting :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkConnecting tmp = do
|
||||
gLink <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
alice ##> "/create link #team"
|
||||
getGroupLink alice "team" GRMember True
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "connection request sent!"
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
alice
|
||||
<### [ "1 group links active",
|
||||
"#team: group is empty",
|
||||
"bob (Bob): accepting request to join group #team..."
|
||||
]
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
threadDelay 500000
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: connecting"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "group link: connecting"
|
||||
|
||||
testPlanGroupLinkLeaveRejoin :: HasCallStack => FilePath -> IO ()
|
||||
testPlanGroupLinkLeaveRejoin =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/g team"
|
||||
alice <## "group #team is created"
|
||||
alice <## "to add members use /a team <name> or /create link #team"
|
||||
alice ##> "/create link #team"
|
||||
gLink <- getGroupLink alice "team" GRMember True
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "connection request sent!"
|
||||
alice <## "bob (Bob): accepting request to join group #team..."
|
||||
concurrentlyN_
|
||||
[ do
|
||||
alice <## "bob (Bob): contact is connected"
|
||||
alice <## "bob invited to group #team via your group link"
|
||||
alice <## "#team: bob joined the group",
|
||||
do
|
||||
bob <## "alice (Alice): contact is connected"
|
||||
bob <## "#team: you joined the group"
|
||||
]
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "group link: known group #team"
|
||||
bob <## "use #team <message> to send messages"
|
||||
|
||||
bob ##> "/leave #team"
|
||||
concurrentlyN_
|
||||
[ do
|
||||
bob <## "#team: you left the group"
|
||||
bob <## "use /d #team to delete the group",
|
||||
alice <## "#team: bob left the group"
|
||||
]
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: ok to connect"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "connection request sent!"
|
||||
alice <## "bob_1 (Bob): accepting request to join group #team..."
|
||||
concurrentlyN_
|
||||
[ alice
|
||||
<### [ "bob_1 (Bob): contact is connected",
|
||||
"bob_1 invited to group #team via your group link",
|
||||
EndsWith "joined the group",
|
||||
"contact bob_1 is merged into bob",
|
||||
"use @bob <message> to send messages"
|
||||
],
|
||||
bob
|
||||
<### [ "alice_1 (Alice): contact is connected",
|
||||
"#team_1: you joined the group",
|
||||
"contact alice_1 is merged into alice",
|
||||
"use @alice <message> to send messages"
|
||||
]
|
||||
]
|
||||
|
||||
alice #> "#team hi"
|
||||
bob <# "#team_1 alice> hi"
|
||||
bob #> "#team_1 hey"
|
||||
alice <# "#team bob> hey"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> gLink)
|
||||
bob <## "group link: known group #team_1"
|
||||
bob <## "use #team_1 <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> gLink)
|
||||
bob <## "group link: known group #team_1"
|
||||
bob <## "use #team_1 <message> to send messages"
|
||||
|
||||
testGroupMsgDecryptError :: HasCallStack => FilePath -> IO ()
|
||||
testGroupMsgDecryptError tmp =
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
|
@ -28,6 +28,11 @@ chatProfileTests = do
|
||||
it "delete connection requests when contact link deleted" testDeleteConnectionRequests
|
||||
it "auto-reply message" testAutoReplyMessage
|
||||
it "auto-reply message in incognito" testAutoReplyMessageInIncognito
|
||||
describe "contact address connection plan" $ do
|
||||
it "contact address ok to connect; known contact" testPlanAddressOkKnown
|
||||
it "own contact address" testPlanAddressOwn
|
||||
it "connecting via contact address" testPlanAddressConnecting
|
||||
it "re-connect with deleted contact" testPlanAddressContactDeletedReconnected
|
||||
describe "incognito" $ do
|
||||
it "connect incognito via invitation link" testConnectIncognitoInvitationLink
|
||||
it "connect incognito via contact address" testConnectIncognitoContactAddress
|
||||
@ -369,7 +374,8 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "alice (Alice): contact already exists"
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
alice @@@ [("@bob", lastChatFeature)]
|
||||
bob @@@ [("@alice", lastChatFeature), (":2", ""), (":1", "")]
|
||||
bob ##> "/_delete :1"
|
||||
@ -382,7 +388,8 @@ testDeduplicateContactRequests = testChat3 aliceProfile bobProfile cathProfile $
|
||||
bob @@@ [("@alice", "hey")]
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "alice (Alice): contact already exists"
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
alice <##> bob
|
||||
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (0, "hey"), (1, "hi"), (0, "hey")])
|
||||
@ -440,7 +447,8 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
|
||||
(alice <## "robert (Robert): contact is connected")
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "alice (Alice): contact already exists"
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
alice @@@ [("@robert", lastChatFeature)]
|
||||
bob @@@ [("@alice", lastChatFeature), (":3", ""), (":2", ""), (":1", "")]
|
||||
bob ##> "/_delete :1"
|
||||
@ -455,7 +463,8 @@ testDeduplicateContactRequestsProfileChange = testChat3 aliceProfile bobProfile
|
||||
bob @@@ [("@alice", "hey")]
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "alice (Alice): contact already exists"
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
alice <##> bob
|
||||
alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "hi"), (0, "hey"), (1, "hi"), (0, "hey")])
|
||||
@ -566,6 +575,154 @@ testAutoReplyMessageInIncognito = testChat2 aliceProfile bobProfile $
|
||||
]
|
||||
]
|
||||
|
||||
testPlanAddressOkKnown :: HasCallStack => FilePath -> IO ()
|
||||
testPlanAddressOkKnown =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: ok to connect"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice @@@ [("<@bob", "")]
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
alice <##> bob
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
testPlanAddressOwn :: HasCallStack => FilePath -> IO ()
|
||||
testPlanAddressOwn tmp =
|
||||
withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
|
||||
alice ##> ("/_connect plan 1 " <> cLink)
|
||||
alice <## "contact address: own address"
|
||||
|
||||
alice ##> ("/c " <> cLink)
|
||||
alice <## "connection request sent!"
|
||||
alice <## "alice_1 (Alice) wants to connect to you!"
|
||||
alice <## "to accept: /ac alice_1"
|
||||
alice <## ("to reject: /rc alice_1 (the sender will NOT be notified)")
|
||||
alice @@@ [("<@alice_1", ""), (":2","")]
|
||||
alice ##> "/ac alice_1"
|
||||
alice <## "alice_1 (Alice): accepting contact request..."
|
||||
alice
|
||||
<### [ "alice_1 (Alice): contact is connected",
|
||||
"alice_2 (Alice): contact is connected"
|
||||
]
|
||||
|
||||
alice @@@ [("@alice_1", lastChatFeature), ("@alice_2", lastChatFeature)]
|
||||
alice `send` "@alice_2 hi"
|
||||
alice
|
||||
<### [ WithTime "@alice_2 hi",
|
||||
WithTime "alice_1> hi"
|
||||
]
|
||||
alice `send` "@alice_1 hey"
|
||||
alice
|
||||
<### [ WithTime "@alice_1 hey",
|
||||
WithTime "alice_2> hey"
|
||||
]
|
||||
alice @@@ [("@alice_1", "hey"), ("@alice_2", "hey")]
|
||||
|
||||
alice ##> ("/_connect plan 1 " <> cLink)
|
||||
alice <## "contact address: own address"
|
||||
|
||||
alice ##> ("/c " <> cLink)
|
||||
alice <## "alice_2 (Alice): contact already exists"
|
||||
|
||||
testPlanAddressConnecting :: HasCallStack => FilePath -> IO ()
|
||||
testPlanAddressConnecting tmp = do
|
||||
cLink <- withNewTestChat tmp "alice" aliceProfile $ \alice -> do
|
||||
alice ##> "/ad"
|
||||
getContactLink alice True
|
||||
withNewTestChat tmp "bob" bobProfile $ \bob -> do
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "connection request sent!"
|
||||
withTestChat tmp "alice" $ \alice -> do
|
||||
alice <## "Your address is active! To show: /sa"
|
||||
alice <## "bob (Bob) wants to connect to you!"
|
||||
alice <## "to accept: /ac bob"
|
||||
alice <## "to reject: /rc bob (the sender will NOT be notified)"
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
withTestChat tmp "bob" $ \bob -> do
|
||||
threadDelay 500000
|
||||
bob @@@ [("@alice", "")]
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: connecting to contact alice"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "contact address: connecting to contact alice"
|
||||
|
||||
testPlanAddressContactDeletedReconnected :: HasCallStack => FilePath -> IO ()
|
||||
testPlanAddressContactDeletedReconnected =
|
||||
testChat2 aliceProfile bobProfile $
|
||||
\alice bob -> do
|
||||
alice ##> "/ad"
|
||||
cLink <- getContactLink alice True
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
alice <#? bob
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
alice <##> bob
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "contact address: known contact alice"
|
||||
bob <## "use @alice <message> to send messages"
|
||||
|
||||
alice ##> "/d bob"
|
||||
alice <## "bob: contact is deleted"
|
||||
bob <## "alice (Alice) deleted contact with you"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: ok to connect"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "connection request sent!"
|
||||
alice <## "bob (Bob) wants to connect to you!"
|
||||
alice <## "to accept: /ac bob"
|
||||
alice <## "to reject: /rc bob (the sender will NOT be notified)"
|
||||
alice ##> "/ac bob"
|
||||
alice <## "bob (Bob): accepting contact request..."
|
||||
concurrently_
|
||||
(bob <## "alice_1 (Alice): contact is connected")
|
||||
(alice <## "bob (Bob): contact is connected")
|
||||
|
||||
alice #> "@bob hi"
|
||||
bob <# "alice_1> hi"
|
||||
bob #> "@alice_1 hey"
|
||||
alice <# "bob> hey"
|
||||
|
||||
bob ##> ("/_connect plan 1 " <> cLink)
|
||||
bob <## "contact address: known contact alice_1"
|
||||
bob <## "use @alice_1 <message> to send messages"
|
||||
|
||||
bob ##> ("/c " <> cLink)
|
||||
bob <## "contact address: known contact alice_1"
|
||||
bob <## "use @alice_1 <message> to send messages"
|
||||
|
||||
testConnectIncognitoInvitationLink :: HasCallStack => FilePath -> IO ()
|
||||
testConnectIncognitoInvitationLink = testChat3 aliceProfile bobProfile cathProfile $
|
||||
\alice bob cath -> do
|
||||
|
Loading…
Reference in New Issue
Block a user