mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-06-04 19:01:57 +00:00
Merge branch 'master' into remote-desktop
This commit is contained in:
Evgeny Poberezkin
+229
-186
@@ -185,13 +185,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
|
||||
currentRemoteHost <- newTVarIO Nothing
|
||||
servers <- agentServers config
|
||||
@@ -200,7 +198,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
|
||||
@@ -218,7 +215,38 @@ newChatController ChatDatabase {chatStore, agentStore} user cfg@ChatConfig {agen
|
||||
userXFTPFileConfig <- newTVarIO $ xftpFileConfig cfg
|
||||
tempDirectory <- newTVarIO tempDir
|
||||
contactMergeEnabled <- newTVarIO True
|
||||
pure ChatController {activeTo, firstTime, currentUser, currentRemoteHost, smpAgent, agentAsync, chatStore, chatStoreChanged, idsDrg, inputQ, outputQ, notifyQ, subscriptionMode, chatLock, sndFiles, rcvFiles, currentCalls, remoteHostSessions, remoteCtrlSession, config, sendNotification, filesFolder, expireCIThreads, expireCIFlags, cleanupManagerAsync, timedItemThreads, showLiveItems, userXFTPFileConfig, tempDirectory, logFilePath = logFile, contactMergeEnabled}
|
||||
pure
|
||||
ChatController
|
||||
{
|
||||
firstTime,
|
||||
currentUser,
|
||||
currentRemoteHost,
|
||||
smpAgent,
|
||||
agentAsync,
|
||||
chatStore,
|
||||
chatStoreChanged,
|
||||
idsDrg,
|
||||
inputQ,
|
||||
outputQ,
|
||||
subscriptionMode,
|
||||
chatLock,
|
||||
sndFiles,
|
||||
rcvFiles,
|
||||
currentCalls,
|
||||
remoteHostSessions,
|
||||
remoteCtrlSession,
|
||||
config,
|
||||
filesFolder,
|
||||
expireCIThreads,
|
||||
expireCIFlags,
|
||||
cleanupManagerAsync,
|
||||
timedItemThreads,
|
||||
showLiveItems,
|
||||
userXFTPFileConfig,
|
||||
tempDirectory,
|
||||
logFilePath = logFile,
|
||||
contactMergeEnabled
|
||||
}
|
||||
where
|
||||
configServers :: DefaultAgentServers
|
||||
configServers =
|
||||
@@ -265,7 +293,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)
|
||||
@@ -389,7 +417,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
|
||||
@@ -415,7 +442,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''
|
||||
@@ -473,11 +499,11 @@ processChatCommand = \case
|
||||
DeleteUser uName delSMPQueues viewPwd_ -> withUserName uName $ \userId -> APIDeleteUser userId delSMPQueues viewPwd_
|
||||
StartChat subConns enableExpireCIs startXFTPWorkers -> withUser' $ \_ ->
|
||||
asks agentAsync >>= readTVarIO >>= \case
|
||||
Just _ -> pure $ CRChatRunning Nothing
|
||||
_ -> checkStoreNotChanged $ startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted Nothing
|
||||
Just _ -> pure CRChatRunning
|
||||
_ -> checkStoreNotChanged $ startChatController subConns enableExpireCIs startXFTPWorkers $> CRChatStarted
|
||||
APIStopChat -> do
|
||||
ask >>= stopChatController
|
||||
pure $ CRChatStopped Nothing
|
||||
pure CRChatStopped
|
||||
APIActivateChat -> withUser $ \_ -> do
|
||||
restoreCalls
|
||||
withAgent foregroundAgent
|
||||
@@ -545,7 +571,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)
|
||||
@@ -559,7 +585,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)
|
||||
@@ -576,7 +602,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))
|
||||
@@ -627,7 +652,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
|
||||
@@ -642,7 +667,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))
|
||||
@@ -747,7 +771,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
|
||||
@@ -763,13 +787,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
|
||||
@@ -786,7 +809,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
|
||||
@@ -795,20 +817,19 @@ 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, CChatItem msgDir ci@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
|
||||
(CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete
|
||||
CTGroup -> do
|
||||
Group gInfo ms <- withStore $ \db -> getGroup db user chatId
|
||||
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, editable}} <- withStore $ \db -> getGroupChatItem db user chatId itemId
|
||||
case (mode, msgDir, itemSharedMsgId, editable) of
|
||||
(CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime
|
||||
(CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do
|
||||
@@ -820,7 +841,7 @@ processChatCommand = \case
|
||||
CTContactConnection -> pure $ chatCmdError (Just user) "not supported"
|
||||
APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do
|
||||
Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId
|
||||
ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId
|
||||
CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withStore $ \db -> getGroupChatItem db user gId itemId
|
||||
case (chatDir, itemSharedMsgId) of
|
||||
(CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do
|
||||
when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete
|
||||
@@ -911,11 +932,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
|
||||
@@ -923,7 +944,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
|
||||
@@ -1175,7 +1195,7 @@ processChatCommand = \case
|
||||
ct <- getContact db user chatId
|
||||
liftIO $ updateContactSettings db user chatId chatSettings
|
||||
pure ct
|
||||
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (enableNtfs chatSettings)
|
||||
withAgent $ \a -> toggleConnectionNtfs a (contactConnId ct) (chatHasNtfs chatSettings)
|
||||
ok user
|
||||
CTGroup -> do
|
||||
ms <- withStore $ \db -> do
|
||||
@@ -1183,9 +1203,17 @@ processChatCommand = \case
|
||||
liftIO $ updateGroupSettings db user chatId chatSettings
|
||||
pure ms
|
||||
forM_ (filter memberActive ms) $ \m -> forM_ (memberConnId m) $ \connId ->
|
||||
withAgent (\a -> toggleConnectionNtfs a connId $ enableNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
|
||||
withAgent (\a -> toggleConnectionNtfs a connId $ chatHasNtfs chatSettings) `catchChatError` (toView . CRChatError (Just user))
|
||||
ok user
|
||||
_ -> pure $ chatCmdError (Just user) "not supported"
|
||||
APISetMemberSettings gId gMemberId settings -> withUser $ \user -> do
|
||||
m <- withStore $ \db -> do
|
||||
liftIO $ updateGroupMemberSettings db user gId gMemberId settings
|
||||
getGroupMember db user gId gMemberId
|
||||
when (memberActive m) $ forM_ (memberConnId m) $ \connId -> do
|
||||
let ntfOn = showMessages $ memberSettings m
|
||||
withAgent (\a -> toggleConnectionNtfs a connId ntfOn) `catchChatError` (toView . CRChatError (Just user))
|
||||
ok user
|
||||
APIContactInfo contactId -> withUser $ \user@User {userId} -> do
|
||||
-- [incognito] print user's incognito profile for this contact
|
||||
ct@Contact {activeConn = Connection {customUserProfileId}} <- withStore $ \db -> getContact db user contactId
|
||||
@@ -1280,6 +1308,11 @@ processChatCommand = \case
|
||||
_ -> throwChatError CEGroupMemberNotActive
|
||||
SetShowMessages cName ntfOn -> updateChatSettings cName (\cs -> cs {enableNtfs = ntfOn})
|
||||
SetSendReceipts cName rcptsOn_ -> updateChatSettings cName (\cs -> cs {sendRcpts = rcptsOn_})
|
||||
SetShowMemberMessages gName mName showMessages -> withUser $ \user -> do
|
||||
(gId, mId) <- getGroupAndMemberId user gName mName
|
||||
m <- withStore $ \db -> getGroupMember db user gId mId
|
||||
let settings = (memberSettings m) {showMessages}
|
||||
processChatCommand $ APISetMemberSettings gId mId settings
|
||||
ContactInfo cName -> withContactName cName APIContactInfo
|
||||
ShowGroupInfo gName -> withUser $ \user -> do
|
||||
groupId <- withStore $ \db -> getGroupIdByName db user gName
|
||||
@@ -1324,6 +1357,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
|
||||
@@ -1336,11 +1371,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 ->
|
||||
@@ -1436,7 +1476,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
|
||||
@@ -1704,11 +1744,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)
|
||||
@@ -1720,10 +1759,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
|
||||
@@ -1949,19 +1988,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
|
||||
@@ -2000,7 +2056,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')
|
||||
@@ -2059,9 +2115,8 @@ processChatCommand = \case
|
||||
when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
|
||||
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 :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> m ChatResponse
|
||||
delGroupChatItem user gInfo ci msgId byGroupMember = do
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
if groupFeatureAllowed SGFFullDelete gInfo
|
||||
then deleteGroupCI user gInfo ci True False byGroupMember deletedTs
|
||||
@@ -2071,10 +2126,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 $ ct.activeConn
|
||||
in s == ConnReady || s == ConnSndReady
|
||||
withCurrentCall :: ContactId -> (User -> Contact -> Call -> m (Maybe Call)) -> m ChatResponse
|
||||
withCurrentCall ctId action = do
|
||||
(user, ct) <- withStore $ \db -> do
|
||||
@@ -2122,7 +2173,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)
|
||||
@@ -2172,7 +2222,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)
|
||||
@@ -2193,6 +2242,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 =
|
||||
@@ -2758,10 +2855,10 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do
|
||||
waitChatStarted
|
||||
case cType of
|
||||
CTDirect -> do
|
||||
(ct, ci) <- withStoreCtx (Just "deleteTimedItem, getContact ...") $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
(ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db user chatId <*> getDirectChatItem db user chatId itemId
|
||||
deleteDirectCI user ct ci True True >>= toView
|
||||
CTGroup -> do
|
||||
(gInfo, ci) <- withStoreCtx (Just "deleteTimedItem, getGroupInfo ...") $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
|
||||
(gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId
|
||||
deletedTs <- liftIO getCurrentTime
|
||||
deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView
|
||||
_ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
|
||||
@@ -2824,17 +2921,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"
|
||||
SUSPENDED -> toView $ CRChatSuspended Nothing
|
||||
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 =
|
||||
@@ -2971,10 +3067,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
|
||||
@@ -3041,7 +3134,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 $ \_ ->
|
||||
@@ -3126,9 +3219,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
|
||||
@@ -3205,7 +3295,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
|
||||
@@ -3287,7 +3377,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
updateGroupMemberStatus db userId membership GSMemConnected
|
||||
-- possible improvement: check for each pending message, requires keeping track of connection state
|
||||
unless (connDisabled conn) $ sendPendingGroupMessages user m conn
|
||||
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ enableNtfs chatSettings
|
||||
withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
|
||||
@@ -3295,15 +3385,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 " <> m.localDisplayName <> " is connected"
|
||||
intros <- withStore' $ \db -> createIntroductions db members m
|
||||
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
|
||||
forM_ intros $ \intro ->
|
||||
@@ -3599,7 +3683,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
|
||||
@@ -3614,10 +3698,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 ()
|
||||
@@ -3708,13 +3789,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
|
||||
@@ -3776,7 +3853,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
|
||||
@@ -3789,23 +3866,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
|
||||
@@ -3864,7 +3936,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
|
||||
@@ -3876,7 +3948,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
|
||||
@@ -3903,7 +3974,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct)
|
||||
where
|
||||
deleteRcvChatItem = do
|
||||
ci@(CChatItem msgDir _) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
|
||||
CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
|
||||
case msgDir of
|
||||
SMDRcv ->
|
||||
if featureAllowed SCFFullDelete forContact ct
|
||||
@@ -3963,7 +4034,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
|
||||
@@ -3984,29 +4055,24 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
createItem timed_ live
|
||||
| groupFeatureAllowed SGFFullDelete gInfo = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo (CChatItem SMDRcv ci) moderator moderatedAt
|
||||
toView $ CRNewChatItem user ci'
|
||||
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
|
||||
toView $ CRNewChatItem user $ AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci'
|
||||
| otherwise = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False
|
||||
cr <- markGroupCIDeleted user gInfo (CChatItem SMDRcv ci) createdByMsgId False (Just moderator) moderatedAt
|
||||
toView cr
|
||||
toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt
|
||||
createItem timed_ live = do
|
||||
file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
||||
ChatItem {formattedText} <- 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 (CIRcvMsgContent content) (snd <$> file_) timed_ live
|
||||
when (showMessages $ memberSettings m) $ autoAcceptFile file_
|
||||
newChatItem ciContent ciFile_ timed_ live = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live
|
||||
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
|
||||
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_
|
||||
groupMsgToView gInfo m ci {reactions} msgMeta
|
||||
pure ci
|
||||
groupMsgToView gInfo m ci' {reactions} msgMeta
|
||||
|
||||
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).
|
||||
@@ -4015,9 +4081,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live
|
||||
ci' <- withStore' $ \db -> do
|
||||
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
||||
updateGroupChatItem db user groupId ci content live Nothing
|
||||
ci' <- updateGroupChatItem db user groupId ci content live Nothing
|
||||
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
|
||||
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
||||
setActive $ ActiveG g
|
||||
where
|
||||
MsgMeta {broker = (_, brokerTs)} = msgMeta
|
||||
content = CIRcvMsgContent mc
|
||||
@@ -4036,7 +4102,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"
|
||||
@@ -4046,7 +4111,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
|
||||
let msgMemberId = fromMaybe memberId sndMemberId_
|
||||
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
|
||||
Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of
|
||||
Right (CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
|
||||
CIGroupRcv mem
|
||||
| sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
|
||||
| otherwise -> deleteMsg mem ci
|
||||
@@ -4056,7 +4121,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
| senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
|
||||
| otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
|
||||
where
|
||||
deleteMsg :: GroupMember -> CChatItem 'CTGroup -> m ()
|
||||
deleteMsg :: MsgDirectionI d => GroupMember -> ChatItem 'CTGroup d -> m ()
|
||||
deleteMsg mem ci = case sndMemberId_ of
|
||||
Just sndMemberId
|
||||
| sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView
|
||||
@@ -4066,13 +4131,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
| senderRole < GRAdmin || senderRole < memberRole =
|
||||
messageError "x.msg.del: message of another member with insufficient member permissions"
|
||||
| otherwise = a
|
||||
delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> m ChatResponse
|
||||
delete ci byGroupMember
|
||||
| groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember brokerTs
|
||||
| otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember brokerTs
|
||||
|
||||
-- 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
|
||||
@@ -4081,24 +4147,23 @@ 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
|
||||
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
||||
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
|
||||
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
|
||||
groupMsgToView gInfo m ci' msgMeta
|
||||
|
||||
blockedMember :: Monad m' => GroupMember -> ChatItem c d -> m' (ChatItem c d) -> m' (ChatItem c d)
|
||||
blockedMember m ci blockedCI
|
||||
| showMessages (memberSettings m) = pure ci
|
||||
| otherwise = blockedCI
|
||||
|
||||
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> m (Maybe InlineFileMode)
|
||||
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
|
||||
@@ -4255,7 +4320,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)
|
||||
@@ -4268,6 +4333,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
|
||||
@@ -4278,8 +4344,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'
|
||||
@@ -4618,7 +4682,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
toView $ CRJoinedGroupMemberConnecting user gInfo m newMember
|
||||
|
||||
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> m ()
|
||||
xGrpMemIntro gInfo@GroupInfo {chatSettings = ChatSettings {enableNtfs}} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
|
||||
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memberChatVRange _) = do
|
||||
case memberCategory m of
|
||||
GCHostMember -> do
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
@@ -4638,7 +4702,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
void $ withStore $ \db -> createIntroReMember db user gInfo m memInfo groupConnIds directConnIds customUserProfileId subMode
|
||||
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
||||
where
|
||||
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv enableNtfs SCMInvitation subMode
|
||||
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode
|
||||
|
||||
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> m ()
|
||||
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
||||
@@ -4661,7 +4725,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
||||
|
||||
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> m ()
|
||||
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings = ChatSettings {enableNtfs}} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
||||
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memberChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
||||
checkHostRole m memRole
|
||||
members <- withStore' $ \db -> getGroupMembers db user gInfo
|
||||
toMember <- case find (sameMemberId memId) members of
|
||||
@@ -4676,8 +4740,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
|
||||
-- [incognito] send membership incognito profile, create direct connection as incognito
|
||||
dm <- directMessage $ XGrpMemInfo membership.memberId (fromLocalProfile $ memberProfile membership)
|
||||
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
||||
groupConnIds <- joinAgentConnectionAsync user enableNtfs groupConnReq dm subMode
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user enableNtfs dcr dm subMode
|
||||
groupConnIds <- joinAgentConnectionAsync user (chatHasNtfs chatSettings) groupConnReq dm subMode
|
||||
directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user True dcr dm subMode
|
||||
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
||||
mcvr = maybe chatInitialVRange fromChatVRange memberChatVRange
|
||||
withStore' $ \db -> createIntroToMemberContact db user m toMember mcvr groupConnIds directConnIds customUserProfileId subMode
|
||||
@@ -5201,20 +5265,22 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs cur
|
||||
meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) currentTs itemTs currentTs currentTs
|
||||
pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file}
|
||||
|
||||
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse
|
||||
deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do
|
||||
deleteDirectCI :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> m ChatResponse
|
||||
deleteDirectCI user ct ci@ChatItem {file} byUser timed = do
|
||||
deleteCIFile user file
|
||||
withStoreCtx' (Just "deleteDirectCI, deleteDirectChatItem") $ \db -> deleteDirectChatItem db user ct ci
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDirection (DirectChat ct) ci) Nothing byUser timed
|
||||
|
||||
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ deletedTs = do
|
||||
deleteGroupCI :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do
|
||||
deleteCIFile user file
|
||||
toCi <- withStoreCtx' (Just "deleteGroupCI, deleteGroupChatItem ...") $ \db ->
|
||||
case byGroupMember_ of
|
||||
Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing
|
||||
Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs
|
||||
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed
|
||||
pure $ CRChatItemDeleted user (gItem ci) (gItem <$> toCi) byUser timed
|
||||
where
|
||||
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
|
||||
|
||||
deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
deleteCIFile user file_ =
|
||||
@@ -5222,25 +5288,21 @@ deleteCIFile user file_ =
|
||||
fileAgentConnIds <- deleteFile' user (mkCIFileInfo file) True
|
||||
deleteAgentConnectionsAsync user fileAgentConnIds
|
||||
|
||||
markDirectCIDeleted :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
||||
markDirectCIDeleted user ct@Contact {contactId} ci@(CChatItem _ ChatItem {file}) msgId byUser deletedTs = do
|
||||
markDirectCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> m ChatResponse
|
||||
markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do
|
||||
cancelCIFile user file
|
||||
toCi <- withStore $ \db -> do
|
||||
liftIO $ markDirectChatItemDeleted db user ct ci msgId deletedTs
|
||||
getDirectChatItem db user contactId (cchatItemId ci)
|
||||
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem toCi) byUser False
|
||||
ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs
|
||||
pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False
|
||||
where
|
||||
ctItem (CChatItem msgDir ci') = AChatItem SCTDirect msgDir (DirectChat ct) ci'
|
||||
ctItem = AChatItem SCTDirect msgDirection (DirectChat ct)
|
||||
|
||||
markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
markGroupCIDeleted user gInfo@GroupInfo {groupId} ci@(CChatItem _ ChatItem {file}) msgId byUser byGroupMember_ deletedTs = do
|
||||
markGroupCIDeleted :: (ChatMonad m, MsgDirectionI d) => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> m ChatResponse
|
||||
markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do
|
||||
cancelCIFile user file
|
||||
toCi <- withStore $ \db -> do
|
||||
liftIO $ markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
|
||||
getGroupChatItem db user groupId (cchatItemId ci)
|
||||
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem toCi) byUser False
|
||||
ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs
|
||||
pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False
|
||||
where
|
||||
gItem (CChatItem msgDir ci') = AChatItem SCTGroup msgDir (GroupChat gInfo) ci'
|
||||
gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo)
|
||||
|
||||
cancelCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
|
||||
cancelCIFile user file_ =
|
||||
@@ -5426,30 +5488,6 @@ 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
|
||||
|
||||
whenContactNtfs :: ChatMonad' m => User -> Contact -> m () -> m ()
|
||||
whenContactNtfs user Contact {chatSettings} = whenUserNtfs user . when (enableNtfs chatSettings)
|
||||
|
||||
whenGroupNtfs :: ChatMonad' m => User -> GroupInfo -> m () -> m ()
|
||||
whenGroupNtfs user GroupInfo {chatSettings} = whenUserNtfs user . when (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
|
||||
|
||||
withUser' :: ChatMonad m => (User -> m ChatResponse) -> m ChatResponse
|
||||
withUser' action =
|
||||
asks currentUser
|
||||
@@ -5487,9 +5525,12 @@ withAgent action =
|
||||
chatCommandP :: Parser ChatCommand
|
||||
chatCommandP =
|
||||
choice
|
||||
[ "/mute " *> ((`SetShowMessages` False) <$> chatNameP),
|
||||
"/unmute " *> ((`SetShowMessages` True) <$> chatNameP),
|
||||
[ "/mute " *> ((`SetShowMessages` MFNone) <$> chatNameP),
|
||||
"/unmute " *> ((`SetShowMessages` MFAll) <$> chatNameP),
|
||||
"/unmute mentions " *> ((`SetShowMessages` MFMentions) <$> chatNameP),
|
||||
"/receipts " *> (SetSendReceipts <$> chatNameP <* " " <*> ((Just <$> onOffP) <|> ("default" $> Nothing))),
|
||||
"/block #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure False),
|
||||
"/unblock #" *> (SetShowMemberMessages <$> displayName <* A.space <*> (char_ '@' *> displayName) <*> pure True),
|
||||
"/_create user " *> (CreateActiveUser <$> jsonP),
|
||||
"/create user " *> (CreateActiveUser <$> newUserP),
|
||||
"/users" $> ListUsers,
|
||||
@@ -5593,6 +5634,7 @@ chatCommandP =
|
||||
("/network" <|> "/net") $> APIGetNetworkConfig,
|
||||
"/reconnect" $> ReconnectAllServers,
|
||||
"/_settings " *> (APISetChatSettings <$> chatRefP <* A.space <*> jsonP),
|
||||
"/_member settings #" *> (APISetMemberSettings <$> A.decimal <* A.space <*> A.decimal <* A.space <*> jsonP),
|
||||
"/_info #" *> (APIGroupMemberInfo <$> A.decimal <* A.space <*> A.decimal),
|
||||
"/_info #" *> (APIGroupInfo <$> A.decimal),
|
||||
"/_info @" *> (APIContactInfo <$> A.decimal),
|
||||
@@ -5667,6 +5709,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),
|
||||
|
||||
Reference in New Issue
Block a user