mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2025-03-14 09:45:42 +00:00
621b291da1
* core: member mentions, types and rfc * update * update rfc * save/get mentions (WIP) * markdown * store received mentions and userMention flag * sent mentions * update message with mentions * db queries * CLI mentions, test passes * use maps for mentions * tests * comment * save mentions on sent messages * postresql schema * refactor * M.empty * include both displayName and localAlias into MentionedMemberInfo * fix saving sent mentions * include mentions in previews * update plans
2909 lines
174 KiB
Haskell
2909 lines
174 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE KindSignatures #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PatternSynonyms #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module Simplex.Chat.Library.Subscriber where
|
|
|
|
import Control.Logger.Simple
|
|
import Control.Monad
|
|
import Control.Monad.Except
|
|
import Control.Monad.IO.Unlift
|
|
import Control.Monad.Reader
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.ByteString.Base64 as B64
|
|
import qualified Data.ByteString.Char8 as B
|
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
|
import Data.Either (lefts, partitionEithers, rights)
|
|
import Data.Functor (($>))
|
|
import Data.Int (Int64)
|
|
import Data.List (foldl', partition)
|
|
import Data.List.NonEmpty (NonEmpty (..), (<|))
|
|
import qualified Data.List.NonEmpty as L
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, mapMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (decodeLatin1)
|
|
import Data.Time (addUTCTime)
|
|
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
|
|
import qualified Data.UUID as UUID
|
|
import qualified Data.UUID.V4 as V4
|
|
import Data.Word (Word32)
|
|
import Simplex.Chat.Call
|
|
import Simplex.Chat.Controller
|
|
import Simplex.Chat.Library.Internal
|
|
import Simplex.Chat.Messages
|
|
import Simplex.Chat.Messages.CIContent
|
|
import Simplex.Chat.Messages.CIContent.Events
|
|
import Simplex.Chat.ProfileGenerator (generateRandomProfile)
|
|
import Simplex.Chat.Protocol
|
|
import Simplex.Chat.Store
|
|
import Simplex.Chat.Store.Connections
|
|
import Simplex.Chat.Store.Direct
|
|
import Simplex.Chat.Store.Files
|
|
import Simplex.Chat.Store.Groups
|
|
import Simplex.Chat.Store.Messages
|
|
import Simplex.Chat.Store.Profiles
|
|
import Simplex.Chat.Store.Shared
|
|
import Simplex.Chat.Types
|
|
import Simplex.Chat.Types.Preferences
|
|
import Simplex.Chat.Types.Shared
|
|
import Simplex.Chat.Util (shuffle)
|
|
import Simplex.FileTransfer.Description (ValidFileDescription)
|
|
import qualified Simplex.FileTransfer.Description as FD
|
|
import Simplex.FileTransfer.Protocol (FilePartyI)
|
|
import qualified Simplex.FileTransfer.Transport as XFTP
|
|
import Simplex.FileTransfer.Types (FileErrorType (..), RcvFileId, SndFileId)
|
|
import Simplex.Messaging.Agent as Agent
|
|
import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..))
|
|
import Simplex.Messaging.Agent.Protocol
|
|
import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..))
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Client (ProxyClientError (..))
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Crypto.File (CryptoFile (..))
|
|
import Simplex.Messaging.Crypto.Ratchet (PQEncryption (..), PQSupport (..), pattern PQEncOff, pattern PQEncOn, pattern PQSupportOff, pattern PQSupportOn)
|
|
import qualified Simplex.Messaging.Crypto.Ratchet as CR
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..))
|
|
import qualified Simplex.Messaging.Protocol as SMP
|
|
import qualified Simplex.Messaging.TMap as TM
|
|
import Simplex.Messaging.Transport (TransportError (..))
|
|
import Simplex.Messaging.Util
|
|
import Simplex.Messaging.Version
|
|
import qualified System.FilePath as FP
|
|
import Text.Read (readMaybe)
|
|
import UnliftIO.Directory
|
|
import UnliftIO.STM
|
|
|
|
smallGroupsRcptsMemLimit :: Int
|
|
smallGroupsRcptsMemLimit = 20
|
|
|
|
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
|
processAgentMessage _ _ (DEL_RCVQS delQs) =
|
|
toView $ CRAgentRcvQueuesDeleted $ L.map rcvQ delQs
|
|
where
|
|
rcvQ (connId, server, rcvId, err_) = DeletedRcvQueue (AgentConnId connId) server (AgentQueueId rcvId) err_
|
|
processAgentMessage _ _ (DEL_CONNS connIds) =
|
|
toView $ CRAgentConnsDeleted $ L.map AgentConnId connIds
|
|
processAgentMessage _ "" (ERR e) =
|
|
toView $ CRChatError Nothing $ ChatErrorAgent e Nothing
|
|
processAgentMessage corrId connId msg = do
|
|
lockEntity <- critical (withStore (`getChatLockEntity` AgentConnId connId))
|
|
withEntityLock "processAgentMessage" lockEntity $ do
|
|
vr <- chatVersionRange
|
|
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
|
|
critical (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case
|
|
Just user -> processAgentMessageConn vr user corrId connId msg `catchChatError` (toView . CRChatError (Just user))
|
|
_ -> throwChatError $ CENoConnectionUser (AgentConnId connId)
|
|
|
|
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
|
|
-- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries,
|
|
-- e.g. when database is locked or busy for longer than 3s.
|
|
-- In this case there is no better mitigation than showing alert:
|
|
-- - without ACK the message delivery will be stuck,
|
|
-- - with ACK message will be lost, as it failed to be saved.
|
|
-- Full app restart is likely to resolve database condition and the message will be received and processed again.
|
|
critical :: CM a -> CM a
|
|
critical a =
|
|
a `catchChatError` \case
|
|
ChatErrorStore SEDBBusyError {message} -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing
|
|
e -> throwError e
|
|
|
|
processAgentMessageNoConn :: AEvent 'AENone -> CM ()
|
|
processAgentMessageNoConn = \case
|
|
CONNECT p h -> hostEvent $ CRHostConnected p h
|
|
DISCONNECT p h -> hostEvent $ CRHostDisconnected p h
|
|
DOWN srv conns -> serverEvent srv conns NSDisconnected CRContactsDisconnected
|
|
UP srv conns -> serverEvent srv conns NSConnected CRContactsSubscribed
|
|
SUSPENDED -> toView CRChatSuspended
|
|
DEL_USER agentUserId -> toView $ CRAgentUserDeleted agentUserId
|
|
ERRS cErrs -> errsEvent cErrs
|
|
where
|
|
hostEvent :: ChatResponse -> CM ()
|
|
hostEvent = whenM (asks $ hostEvents . config) . toView
|
|
serverEvent srv conns nsStatus event = do
|
|
chatModifyVar connNetworkStatuses $ \m -> foldl' (\m' cId -> M.insert cId nsStatus m') m connIds
|
|
ifM (asks $ coreApi . config) (notifyAPI connIds) notifyCLI
|
|
where
|
|
connIds = map AgentConnId conns
|
|
notifyAPI = toView . CRNetworkStatus nsStatus
|
|
notifyCLI = do
|
|
cs <- withStore' (`getConnectionsContacts` conns)
|
|
toView $ event srv cs
|
|
errsEvent :: [(ConnId, AgentErrorType)] -> CM ()
|
|
errsEvent cErrs = do
|
|
vr <- chatVersionRange
|
|
errs <- lift $ rights <$> withStoreBatch' (\db -> map (getChatErr vr db) cErrs)
|
|
toView $ CRChatErrors Nothing errs
|
|
where
|
|
getChatErr :: VersionRangeChat -> DB.Connection -> (ConnId, AgentErrorType) -> IO ChatError
|
|
getChatErr vr db (connId, err) =
|
|
let acId = AgentConnId connId
|
|
in ChatErrorAgent err <$> (getUserByAConnId db acId $>>= \user -> eitherToMaybe <$> runExceptT (getConnectionEntity db vr user acId))
|
|
|
|
processAgentMsgSndFile :: ACorrId -> SndFileId -> AEvent 'AESndFile -> CM ()
|
|
processAgentMsgSndFile _corrId aFileId msg = do
|
|
(cRef_, fileId) <- withStore (`getXFTPSndFileDBIds` AgentSndFileId aFileId)
|
|
withEntityLock_ cRef_ . withFileLock "processAgentMsgSndFile" fileId $
|
|
withStore' (`getUserByASndFileId` AgentSndFileId aFileId) >>= \case
|
|
Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user))
|
|
_ -> do
|
|
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
|
throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
|
|
where
|
|
withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
|
|
withEntityLock_ cRef_ = case cRef_ of
|
|
Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgSndFile" contactId
|
|
Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgSndFile" groupId
|
|
_ -> id
|
|
process :: User -> FileTransferId -> CM ()
|
|
process user fileId = do
|
|
(ft@FileTransferMeta {xftpRedirectFor, cancelled}, sfts) <- withStore $ \db -> getSndFileTransfer db user fileId
|
|
vr <- chatVersionRange
|
|
unless cancelled $ case msg of
|
|
SFPROG sndProgress sndTotal -> do
|
|
let status = CIFSSndTransfer {sndProgress, sndTotal}
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateCIFileStatus db user fileId status
|
|
lookupChatItemByFileId db vr user fileId
|
|
toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal
|
|
SFDONE sndDescr rfds -> do
|
|
withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr)
|
|
ci <- withStore $ \db -> lookupChatItemByFileId db vr user fileId
|
|
case ci of
|
|
Nothing -> do
|
|
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
|
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText rfds)
|
|
case rfds of
|
|
[] -> sendFileError (FileErrOther "no receiver descriptions") "no receiver descriptions" vr ft
|
|
rfd : _ -> case [fd | fd@(FD.ValidFileDescription FD.FileDescription {chunks = [_]}) <- rfds] of
|
|
[] -> case xftpRedirectFor of
|
|
Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CRSndFileRedirectStartXFTP user ft
|
|
Just _ -> sendFileError (FileErrOther "chaining redirects") "Prohibit chaining redirects" vr ft
|
|
rfds' -> do
|
|
-- we have 1 chunk - use it as URI whether it is redirect or not
|
|
ft' <- maybe (pure ft) (\fId -> withStore $ \db -> getFileTransferMeta db user fId) xftpRedirectFor
|
|
toView $ CRSndStandaloneFileComplete user ft' $ map (decodeLatin1 . strEncode . FD.fileDescriptionURI) rfds'
|
|
Just (AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) ->
|
|
case (msgId_, itemDeleted) of
|
|
(Just sharedMsgId, Nothing) -> do
|
|
when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send"
|
|
-- TODO either update database status or move to SFPROG
|
|
toView $ CRSndFileProgressXFTP user ci ft 1 1
|
|
case (rfds, sfts, d, cInfo) of
|
|
(rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do
|
|
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
|
conn@Connection {connId} <- liftEither $ contactSendConn_ ct
|
|
sendFileDescriptions (ConnectionId connId) ((conn, sft, fileDescrText rfd) :| []) sharedMsgId >>= \case
|
|
Just rs -> case L.last rs of
|
|
Right ([msgDeliveryId], _) ->
|
|
withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId
|
|
Right (deliveryIds, _) -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds)
|
|
Left e -> toView $ CRChatError (Just user) e
|
|
Nothing -> toView $ CRChatError (Just user) $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result"
|
|
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
|
(_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do
|
|
ms <- withStore' $ \db -> getGroupMembers db vr user g
|
|
let rfdsMemberFTs = zipWith (\rfd (conn, sft) -> (conn, sft, fileDescrText rfd)) rfds (memberFTs ms)
|
|
extraRFDs = drop (length rfdsMemberFTs) rfds
|
|
withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs)
|
|
forM_ (L.nonEmpty rfdsMemberFTs) $ \rfdsMemberFTs' ->
|
|
sendFileDescriptions (GroupId groupId) rfdsMemberFTs' sharedMsgId
|
|
ci' <- withStore $ \db -> do
|
|
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
|
|
getChatItemByFileId db vr user fileId
|
|
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
|
toView $ CRSndFileCompleteXFTP user ci' ft
|
|
where
|
|
memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)]
|
|
memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts')
|
|
where
|
|
mConns' = mapMaybe useMember ms
|
|
sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts
|
|
-- Should match memberSendAction logic
|
|
useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}}
|
|
| (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) && not (connInactive conn) =
|
|
Just (groupMemberId, conn)
|
|
| otherwise = Nothing
|
|
useMember _ = Nothing
|
|
_ -> pure ()
|
|
_ -> pure () -- TODO error?
|
|
SFWARN e -> do
|
|
let err = tshow e
|
|
logWarn $ "Sent file warning: " <> err
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateCIFileStatus db user fileId (CIFSSndWarning $ agentFileError e)
|
|
lookupChatItemByFileId db vr user fileId
|
|
toView $ CRSndFileWarning user ci ft err
|
|
SFERR e ->
|
|
sendFileError (agentFileError e) (tshow e) vr ft
|
|
where
|
|
fileDescrText :: FilePartyI p => ValidFileDescription p -> T.Text
|
|
fileDescrText = safeDecodeUtf8 . strEncode
|
|
sendFileDescriptions :: ConnOrGroupId -> NonEmpty (Connection, SndFileTransfer, RcvFileDescrText) -> SharedMsgId -> CM (Maybe (NonEmpty (Either ChatError ([Int64], PQEncryption))))
|
|
sendFileDescriptions connOrGroupId connsTransfersDescrs sharedMsgId = do
|
|
lift . void . withStoreBatch' $ \db -> L.map (\(_, sft, rfdText) -> updateSndFTDescrXFTP db user sft rfdText) connsTransfersDescrs
|
|
partSize <- asks $ xftpDescrPartSize . config
|
|
let connsIdsEvts = connDescrEvents partSize
|
|
sndMsgs_ <- lift $ createSndMessages $ L.map snd connsIdsEvts
|
|
let (errs, msgReqs) = partitionEithers . L.toList $ L.zipWith (fmap . toMsgReq) connsIdsEvts sndMsgs_
|
|
delivered <- mapM deliverMessages (L.nonEmpty msgReqs)
|
|
let errs' = errs <> maybe [] (lefts . L.toList) delivered
|
|
unless (null errs') $ toView $ CRChatErrors (Just user) errs'
|
|
pure delivered
|
|
where
|
|
connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, ChatMsgEvent 'Json))
|
|
connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs)
|
|
where
|
|
splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, ChatMsgEvent 'Json))]
|
|
splitText (conn, _, rfdText) =
|
|
map (\fileDescr -> (conn, (connOrGroupId, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText)
|
|
toMsgReq :: (Connection, (ConnOrGroupId, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq
|
|
toMsgReq (conn, _) SndMessage {msgId, msgBody} =
|
|
(conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, msgBody, [msgId])
|
|
sendFileError :: FileError -> Text -> VersionRangeChat -> FileTransferMeta -> CM ()
|
|
sendFileError ferr err vr ft = do
|
|
logError $ "Sent file error: " <> err
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateFileCancelled db user fileId (CIFSSndError ferr)
|
|
lookupChatItemByFileId db vr user fileId
|
|
lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId)
|
|
toView $ CRSndFileError user ci ft err
|
|
|
|
agentFileError :: AgentErrorType -> FileError
|
|
agentFileError = \case
|
|
XFTP _ XFTP.AUTH -> FileErrAuth
|
|
XFTP srv (XFTP.BLOCKED info) -> FileErrBlocked srv info
|
|
FILE NO_FILE -> FileErrNoFile
|
|
BROKER _ e -> brokerError FileErrRelay e
|
|
e -> FileErrOther $ tshow e
|
|
where
|
|
brokerError srvErr = \case
|
|
HOST -> srvErr SrvErrHost
|
|
SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion
|
|
e -> srvErr . SrvErrOther $ tshow e
|
|
|
|
splitFileDescr :: Int -> RcvFileDescrText -> NonEmpty FileDescr
|
|
splitFileDescr partSize rfdText = splitParts 1 rfdText
|
|
where
|
|
splitParts partNo remText =
|
|
let (part, rest) = T.splitAt partSize remText
|
|
complete = T.null rest
|
|
fileDescr = FileDescr {fileDescrText = part, fileDescrPartNo = partNo, fileDescrComplete = complete}
|
|
in if complete
|
|
then fileDescr :| []
|
|
else fileDescr <| splitParts (partNo + 1) rest
|
|
|
|
processAgentMsgRcvFile :: ACorrId -> RcvFileId -> AEvent 'AERcvFile -> CM ()
|
|
processAgentMsgRcvFile _corrId aFileId msg = do
|
|
(cRef_, fileId) <- withStore (`getXFTPRcvFileDBIds` AgentRcvFileId aFileId)
|
|
withEntityLock_ cRef_ . withFileLock "processAgentMsgRcvFile" fileId $
|
|
withStore' (`getUserByARcvFileId` AgentRcvFileId aFileId) >>= \case
|
|
Just user -> process user fileId `catchChatError` (toView . CRChatError (Just user))
|
|
_ -> do
|
|
lift $ withAgent' (`xftpDeleteRcvFile` aFileId)
|
|
throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
|
|
where
|
|
withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
|
|
withEntityLock_ cRef_ = case cRef_ of
|
|
Just (ChatRef CTDirect contactId) -> withContactLock "processAgentMsgRcvFile" contactId
|
|
Just (ChatRef CTGroup groupId) -> withGroupLock "processAgentMsgRcvFile" groupId
|
|
_ -> id
|
|
process :: User -> FileTransferId -> CM ()
|
|
process user fileId = do
|
|
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
|
vr <- chatVersionRange
|
|
unless (rcvFileCompleteOrCancelled ft) $ case msg of
|
|
RFPROG rcvProgress rcvTotal -> do
|
|
let status = CIFSRcvTransfer {rcvProgress, rcvTotal}
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateCIFileStatus db user fileId status
|
|
lookupChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileProgressXFTP user ci rcvProgress rcvTotal ft
|
|
RFDONE xftpPath ->
|
|
case liveRcvFileTransferPath ft of
|
|
Nothing -> throwChatError $ CEInternalError "no target path for received XFTP file"
|
|
Just targetPath -> do
|
|
fsTargetPath <- lift $ toFSFilePath targetPath
|
|
renameFile xftpPath fsTargetPath
|
|
ci_ <- withStore $ \db -> do
|
|
liftIO $ do
|
|
updateRcvFileStatus db fileId FSComplete
|
|
updateCIFileStatus db user fileId CIFSRcvComplete
|
|
lookupChatItemByFileId db vr user fileId
|
|
agentXFTPDeleteRcvFile aFileId fileId
|
|
toView $ maybe (CRRcvStandaloneFileComplete user fsTargetPath ft) (CRRcvFileComplete user) ci_
|
|
RFWARN e -> do
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e)
|
|
lookupChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileWarning user ci e ft
|
|
RFERR e
|
|
| e == FILE NOT_APPROVED -> do
|
|
aci_ <- resetRcvCIFileStatus user fileId CIFSRcvAborted
|
|
forM_ aci_ cleanupACIFile
|
|
agentXFTPDeleteRcvFile aFileId fileId
|
|
forM_ aci_ $ \aci -> toView $ CRChatItemUpdated user aci
|
|
| otherwise -> do
|
|
aci_ <- withStore $ \db -> do
|
|
liftIO $ updateFileCancelled db user fileId (CIFSRcvError $ agentFileError e)
|
|
lookupChatItemByFileId db vr user fileId
|
|
forM_ aci_ cleanupACIFile
|
|
agentXFTPDeleteRcvFile aFileId fileId
|
|
toView $ CRRcvFileError user aci_ e ft
|
|
|
|
processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
|
|
processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = do
|
|
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
|
|
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
|
|
-- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition
|
|
-- that will be resolved with app restart.
|
|
entity <- critical $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus
|
|
case agentMessage of
|
|
END -> case entity of
|
|
RcvDirectMsgConnection _ (Just ct) -> toView $ CRContactAnotherClient user ct
|
|
_ -> toView $ CRSubscriptionEnd user entity
|
|
MSGNTF msgId msgTs_ -> toView $ CRNtfMessage user entity $ ntfMsgAckInfo msgId msgTs_
|
|
_ -> case entity of
|
|
RcvDirectMsgConnection conn contact_ ->
|
|
processDirectMessage agentMessage entity conn contact_
|
|
RcvGroupMsgConnection conn gInfo m ->
|
|
processGroupMessage agentMessage entity conn gInfo m
|
|
RcvFileConnection conn ft ->
|
|
processRcvFileConn agentMessage entity conn ft
|
|
SndFileConnection conn ft ->
|
|
processSndFileConn agentMessage entity conn ft
|
|
UserContactConnection conn uc ->
|
|
processUserContactRequest agentMessage entity conn uc
|
|
where
|
|
updateConnStatus :: ConnectionEntity -> CM ConnectionEntity
|
|
updateConnStatus acEntity = case agentMsgConnStatus agentMessage of
|
|
Just connStatus -> do
|
|
let conn = (entityConnection acEntity) {connStatus}
|
|
withStore' $ \db -> updateConnectionStatus db conn connStatus
|
|
pure $ updateEntityConnStatus acEntity connStatus
|
|
Nothing -> pure acEntity
|
|
|
|
agentMsgConnStatus :: AEvent e -> Maybe ConnStatus
|
|
agentMsgConnStatus = \case
|
|
JOINED True -> Just ConnSndReady
|
|
CONF {} -> Just ConnRequested
|
|
INFO {} -> Just ConnSndReady
|
|
CON _ -> Just ConnReady
|
|
_ -> Nothing
|
|
|
|
processCONFpqSupport :: Connection -> PQSupport -> CM Connection
|
|
processCONFpqSupport conn@Connection {connId, pqSupport = pq} pq'
|
|
| pq == PQSupportOn && pq' == PQSupportOff = do
|
|
let pqEnc' = CR.pqSupportToEnc pq'
|
|
withStore' $ \db -> updateConnSupportPQ db connId pq' pqEnc'
|
|
pure (conn {pqSupport = pq', pqEncryption = pqEnc'} :: Connection)
|
|
| pq /= pq' = do
|
|
messageWarning "processCONFpqSupport: unexpected pqSupport change"
|
|
pure conn
|
|
| otherwise = pure conn
|
|
|
|
processINFOpqSupport :: Connection -> PQSupport -> CM ()
|
|
processINFOpqSupport Connection {pqSupport = pq} pq' =
|
|
when (pq /= pq') $ messageWarning "processINFOpqSupport: unexpected pqSupport change"
|
|
|
|
processDirectMessage :: AEvent e -> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
|
|
processDirectMessage agentMsg connEntity conn@Connection {connId, connChatVersion, peerChatVRange, viaUserContactLink, customUserProfileId, connectionCode} = \case
|
|
Nothing -> case agentMsg of
|
|
CONF confId pqSupport _ connInfo -> do
|
|
conn' <- processCONFpqSupport conn pqSupport
|
|
-- [incognito] send saved profile
|
|
(conn'', inGroup) <- saveConnInfo conn' connInfo
|
|
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
|
let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing inGroup
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
|
|
INFO pqSupport connInfo -> do
|
|
processINFOpqSupport conn pqSupport
|
|
void $ saveConnInfo conn connInfo
|
|
MSG meta _msgFlags _msgBody ->
|
|
-- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet,
|
|
-- chat item is also not created here
|
|
withAckMessage' "new contact msg" agentConnId meta $ pure ()
|
|
SENT msgId _proxy -> do
|
|
void $ continueSending connEntity conn
|
|
sentMsgDeliveryEvent conn msgId
|
|
OK ->
|
|
-- [async agent commands] continuation on receiving OK
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
JOINED _ ->
|
|
-- [async agent commands] continuation on receiving JOINED
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
QCONT ->
|
|
void $ continueSending connEntity conn
|
|
MWARN _ err ->
|
|
processConnMWARN connEntity conn err
|
|
MERR _ err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
processConnMERR connEntity conn err
|
|
MERRS _ err -> do
|
|
-- error cannot be AUTH error here
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
Just ct@Contact {contactId} -> case agentMsg of
|
|
INV (ACR _ cReq) ->
|
|
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
|
withCompletedCommand conn agentMsg $ \_ ->
|
|
case cReq of
|
|
directConnReq@(CRInvitationUri _ _) -> do
|
|
contData <- withStore' $ \db -> do
|
|
setConnConnReqInv db user connId cReq
|
|
getXGrpMemIntroContDirect db user ct
|
|
forM_ contData $ \(hostConnId, xGrpMemIntroCont) ->
|
|
sendXGrpMemInv hostConnId (Just directConnReq) xGrpMemIntroCont
|
|
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
|
MSG msgMeta _msgFlags msgBody -> do
|
|
tags <- newTVarIO []
|
|
withAckMessage "contact msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do
|
|
let MsgMeta {pqEncryption} = msgMeta
|
|
(ct', conn') <- updateContactPQRcv user ct conn pqEncryption
|
|
checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure ()
|
|
forM_ aChatMsgs $ \case
|
|
Right (ACMsg _ chatMsg) ->
|
|
processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
|
|
Left e -> do
|
|
atomically $ modifyTVar' tags ("error" :)
|
|
logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e
|
|
toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
|
|
checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent
|
|
where
|
|
aChatMsgs = parseChatMessages msgBody
|
|
processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
|
|
processEvent ct' conn' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do
|
|
let tag = toCMEventTag chatMsgEvent
|
|
atomically $ modifyTVar' tags (tshow tag :)
|
|
logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo
|
|
(conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg
|
|
let ct'' = ct' {activeConn = Just conn''} :: Contact
|
|
case event of
|
|
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
|
|
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
|
|
XMsgUpdate sharedMsgId mContent _ ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
|
|
XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta
|
|
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
|
|
-- TODO discontinue XFile
|
|
XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta
|
|
XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId
|
|
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName
|
|
XInfo p -> xInfo ct'' p
|
|
XDirectDel -> xDirectDel ct'' msg msgMeta
|
|
XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta
|
|
XInfoProbe probe -> xInfoProbe (COMContact ct'') probe
|
|
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct'') probeHash
|
|
XInfoProbeOk probe -> xInfoProbeOk (COMContact ct'') probe
|
|
XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta
|
|
XCallOffer callId offer -> xCallOffer ct'' callId offer msg
|
|
XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg
|
|
XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg
|
|
XCallEnd callId -> xCallEnd ct'' callId msg
|
|
BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta
|
|
_ -> messageError $ "unsupported message: " <> T.pack (show event)
|
|
checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool
|
|
checkSendRcpt ct' aMsgs = do
|
|
let Contact {chatSettings = ChatSettings {sendRcpts}} = ct'
|
|
pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs
|
|
where
|
|
aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) =
|
|
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
|
|
RCVD msgMeta msgRcpt ->
|
|
withAckMessage' "contact rcvd" agentConnId msgMeta $
|
|
directMsgReceived ct conn msgMeta msgRcpt
|
|
CONF confId pqSupport _ connInfo -> do
|
|
conn' <- processCONFpqSupport conn pqSupport
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn' connInfo
|
|
conn'' <- updatePeerChatVRange conn' chatVRange
|
|
case chatMsgEvent of
|
|
-- confirming direct connection with a member
|
|
XGrpMemInfo _memId _memProfile -> do
|
|
-- TODO check member ID
|
|
-- TODO update member profile
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
allowAgentConnectionAsync user conn'' confId XOk
|
|
XInfo profile -> do
|
|
ct' <- processContactProfileUpdate ct profile False `catchChatError` const (pure ct)
|
|
-- [incognito] send incognito profile
|
|
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId
|
|
let p = userProfileToSend user (fromLocalProfile <$> incognitoProfile) (Just ct') False
|
|
allowAgentConnectionAsync user conn'' confId $ XInfo p
|
|
void $ withStore' $ \db -> resetMemberContactFields db ct'
|
|
XGrpLinkInv glInv -> do
|
|
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
|
|
(gInfo, host) <- withStore $ \db -> do
|
|
liftIO $ deleteContactCardKeepConn db connId ct
|
|
createGroupInvitedViaLink db vr user conn'' glInv
|
|
-- [incognito] send saved profile
|
|
incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId)
|
|
let profileToSend = userProfileToSend user (fromLocalProfile <$> incognitoProfile) Nothing True
|
|
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
|
|
toView $ CRBusinessLinkConnecting user gInfo host ct
|
|
_ -> messageError "CONF for existing contact must have x.grp.mem.info or x.info"
|
|
INFO pqSupport connInfo -> do
|
|
processINFOpqSupport conn pqSupport
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
_conn' <- updatePeerChatVRange conn chatVRange
|
|
case chatMsgEvent of
|
|
XGrpMemInfo _memId _memProfile -> do
|
|
-- TODO check member ID
|
|
-- TODO update member profile
|
|
pure ()
|
|
XInfo profile ->
|
|
void $ processContactProfileUpdate ct profile False
|
|
XOk -> pure ()
|
|
_ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok"
|
|
CON pqEnc ->
|
|
withStore' (\db -> getViaGroupMember db vr user ct) >>= \case
|
|
Nothing -> do
|
|
when (pqEnc == PQEncOn) $ withStore' $ \db -> updateConnPQEnabledCON db connId pqEnc
|
|
let conn' = conn {pqSndEnabled = Just pqEnc, pqRcvEnabled = Just pqEnc} :: Connection
|
|
ct' = ct {activeConn = Just conn'} :: Contact
|
|
-- [incognito] print incognito profile used for this contact
|
|
incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId)
|
|
lift $ setContactNetworkStatus ct' NSConnected
|
|
toView $ CRContactConnected user ct' (fmap fromLocalProfile incognitoProfile)
|
|
when (directOrUsed ct') $ do
|
|
unless (contactUsed ct') $ withFastStore' $ \db -> updateContactUsed db user ct'
|
|
createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo pqEnc) Nothing
|
|
createFeatureEnabledItems ct'
|
|
when (contactConnInitiated conn') $ do
|
|
let Connection {groupLinkId} = conn'
|
|
doProbeContacts = isJust groupLinkId
|
|
probeMatchingContactsAndMembers ct' (contactConnIncognito ct') doProbeContacts
|
|
withStore' $ \db -> resetContactConnInitiated db user conn'
|
|
forM_ viaUserContactLink $ \userContactLinkId -> do
|
|
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
|
let (UserContactLink {autoAccept}, groupId_, gLinkMemRole) = ucl
|
|
when (connChatVersion < batchSend2Version) $ sendAutoReply ct' autoAccept
|
|
forM_ groupId_ $ \groupId -> do
|
|
groupInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
|
subMode <- chatReadVar subscriptionMode
|
|
groupConnIds <- createAgentConnectionAsync user CFCreateConnGrpInv True SCMInvitation subMode
|
|
gVar <- asks random
|
|
withStore $ \db -> createNewContactMemberAsync db gVar user groupInfo ct' gLinkMemRole groupConnIds connChatVersion peerChatVRange subMode
|
|
Just (gInfo, m@GroupMember {activeConn}) ->
|
|
when (maybe False ((== ConnReady) . connStatus) activeConn) $ do
|
|
notifyMemberConnected gInfo m $ Just ct
|
|
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
|
when (memberCategory m == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
|
|
SENT msgId proxy -> do
|
|
void $ continueSending connEntity conn
|
|
sentMsgDeliveryEvent conn msgId
|
|
checkSndInlineFTComplete conn msgId
|
|
cis <- withStore $ \db -> do
|
|
cis <- updateDirectItemsStatus' db ct conn msgId (CISSndSent SSPComplete)
|
|
liftIO $ forM cis $ \ci -> setDirectSndChatItemViaProxy db user ct ci (isJust proxy)
|
|
let acis = map ctItem cis
|
|
unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis
|
|
where
|
|
ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct)
|
|
SWITCH qd phase cStats -> do
|
|
toView $ CRContactSwitch user ct (SwitchProgress qd phase cStats)
|
|
when (phase == SPStarted || phase == SPCompleted) $ case qd of
|
|
QDRcv -> createInternalChatItem user (CDDirectSnd ct) (CISndConnEvent $ SCESwitchQueue phase Nothing) Nothing
|
|
QDSnd -> createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
|
RSYNC rss cryptoErr_ cStats ->
|
|
case (rss, connectionCode, cryptoErr_) of
|
|
(RSRequired, _, Just cryptoErr) -> processErr cryptoErr
|
|
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
|
|
(RSAgreed, Just _, _) -> do
|
|
withStore' $ \db -> setConnectionVerified db user connId Nothing
|
|
let ct' = ct {activeConn = Just $ (conn :: Connection) {connectionCode = Nothing}} :: Contact
|
|
ratchetSyncEventItem ct'
|
|
securityCodeChanged ct'
|
|
_ -> ratchetSyncEventItem ct
|
|
where
|
|
processErr cryptoErr = do
|
|
let e@(mde, n) = agentMsgDecryptError cryptoErr
|
|
ci_ <- withStore $ \db ->
|
|
getDirectChatItemLast db user contactId
|
|
>>= liftIO
|
|
. mapM (\(ci, content') -> updateDirectChatItem' db user contactId ci content' False False Nothing Nothing)
|
|
. mdeUpdatedCI e
|
|
case ci_ of
|
|
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
|
_ -> do
|
|
toView $ CRContactRatchetSync user ct (RatchetSyncProgress rss cStats)
|
|
createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing
|
|
ratchetSyncEventItem ct' = do
|
|
toView $ CRContactRatchetSync user ct' (RatchetSyncProgress rss cStats)
|
|
createInternalChatItem user (CDDirectRcv ct') (CIRcvConnEvent $ RCERatchetSync rss) Nothing
|
|
OK ->
|
|
-- [async agent commands] continuation on receiving OK
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
JOINED sqSecured ->
|
|
-- [async agent commands] continuation on receiving JOINED
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData ->
|
|
when (directOrUsed ct && sqSecured) $ do
|
|
lift $ setContactNetworkStatus ct NSConnected
|
|
toView $ CRContactSndReady user ct
|
|
forM_ viaUserContactLink $ \userContactLinkId -> do
|
|
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
|
let (UserContactLink {autoAccept}, _, _) = ucl
|
|
when (connChatVersion >= batchSend2Version) $ sendAutoReply ct autoAccept
|
|
QCONT ->
|
|
void $ continueSending connEntity conn
|
|
MWARN msgId err -> do
|
|
updateDirectItemStatus ct conn msgId (CISSndWarning $ agentSndError err)
|
|
processConnMWARN connEntity conn err
|
|
MERR msgId err -> do
|
|
updateDirectItemStatus ct conn msgId (CISSndError $ agentSndError err)
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
processConnMERR connEntity conn err
|
|
MERRS msgIds err -> do
|
|
-- error cannot be AUTH error here
|
|
updateDirectItemsStatusMsgs ct conn (L.toList msgIds) (CISSndError $ agentSndError err)
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
where
|
|
sendAutoReply ct = \case
|
|
Just AutoAccept {autoReply = Just mc} -> do
|
|
(msg, _) <- sendDirectContactMessage user ct (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
|
ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc)
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci]
|
|
_ -> pure ()
|
|
|
|
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM ()
|
|
processGroupMessage agentMsg connEntity conn@Connection {connId, connChatVersion, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of
|
|
INV (ACR _ cReq) ->
|
|
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
|
|
case cReq of
|
|
groupConnReq@(CRInvitationUri _ _) -> case cmdFunction of
|
|
-- [async agent commands] XGrpMemIntro continuation on receiving INV
|
|
CFCreateConnGrpMemInv
|
|
| maxVersion (peerChatVRange conn) >= groupDirectInvVersion -> sendWithoutDirectCReq
|
|
| otherwise -> sendWithDirectCReq
|
|
where
|
|
sendWithoutDirectCReq = do
|
|
let GroupMember {groupMemberId, memberId} = m
|
|
hostConnId <- withStore $ \db -> do
|
|
liftIO $ setConnConnReqInv db user connId cReq
|
|
getHostConnId db user groupId
|
|
sendXGrpMemInv hostConnId Nothing XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
|
sendWithDirectCReq = do
|
|
let GroupMember {groupMemberId, memberId} = m
|
|
contData <- withStore' $ \db -> do
|
|
setConnConnReqInv db user connId cReq
|
|
getXGrpMemIntroContGroup db user m
|
|
forM_ contData $ \(hostConnId, directConnReq) ->
|
|
sendXGrpMemInv hostConnId (Just directConnReq) XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq}
|
|
-- [async agent commands] group link auto-accept continuation on receiving INV
|
|
CFCreateConnGrpInv -> do
|
|
ct <- withStore $ \db -> getContactViaMember db vr user m
|
|
withStore' $ \db -> setNewContactMemberConnRequest db user m cReq
|
|
groupLinkId <- withStore' $ \db -> getGroupLinkId db user gInfo
|
|
sendGrpInvitation ct m groupLinkId
|
|
toView $ CRSentGroupInvitation user gInfo ct m
|
|
where
|
|
sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM ()
|
|
sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do
|
|
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
|
let GroupMember {memberRole = userRole, memberId = userMemberId} = membership
|
|
groupInv =
|
|
GroupInvitation
|
|
{ fromMember = MemberIdRole userMemberId userRole,
|
|
invitedMember = MemberIdRole memberId memRole,
|
|
connRequest = cReq,
|
|
groupProfile,
|
|
business = Nothing,
|
|
groupLinkId = groupLinkId,
|
|
groupSize = Just currentMemCount
|
|
}
|
|
(_msg, _) <- sendDirectContactMessage user ct $ XGrpInv groupInv
|
|
-- we could link chat item with sent group invitation message (_msg)
|
|
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
|
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
|
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
|
CONF confId _pqSupport _ connInfo -> do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
conn' <- updatePeerChatVRange conn chatVRange
|
|
case memberCategory m of
|
|
GCInviteeMember ->
|
|
case chatMsgEvent of
|
|
XGrpAcpt memId
|
|
| sameMemberId memId m -> do
|
|
withStore $ \db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
allowAgentConnectionAsync user conn' confId XOk
|
|
| otherwise -> messageError "x.grp.acpt: memberId is different from expected"
|
|
_ -> messageError "CONF from invited member must have x.grp.acpt"
|
|
_ ->
|
|
case chatMsgEvent of
|
|
XGrpMemInfo memId _memProfile
|
|
| sameMemberId memId m -> do
|
|
let GroupMember {memberId = membershipMemId} = membership
|
|
membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership
|
|
-- TODO update member profile
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile
|
|
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
|
_ -> messageError "CONF from member must have x.grp.mem.info"
|
|
INFO _pqSupport connInfo -> do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
_conn' <- updatePeerChatVRange conn chatVRange
|
|
case chatMsgEvent of
|
|
XGrpMemInfo memId _memProfile
|
|
| sameMemberId memId m -> do
|
|
-- TODO update member profile
|
|
pure ()
|
|
| otherwise -> messageError "x.grp.mem.info: memberId is different from expected"
|
|
XInfo _ -> pure () -- sent when connecting via group link
|
|
XOk -> pure ()
|
|
_ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok"
|
|
pure ()
|
|
CON _pqEnc -> do
|
|
withStore' $ \db -> do
|
|
updateGroupMemberStatus db userId m GSMemConnected
|
|
unless (memberActive membership) $
|
|
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) $ chatHasNtfs chatSettings
|
|
case memberCategory m of
|
|
GCHostMember -> do
|
|
toView $ CRUserJoinedGroup user gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected}
|
|
let cd = CDGroupRcv gInfo m
|
|
createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = PQEncOff}) Nothing
|
|
createGroupFeatureItems user cd CIRcvGroupFeature gInfo
|
|
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
|
memberConnectedChatItem gInfo m
|
|
unless expectHistory $ forM_ description $ groupDescriptionChatItem gInfo m
|
|
where
|
|
expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion
|
|
GCInviteeMember -> do
|
|
memberConnectedChatItem gInfo m
|
|
toView $ CRJoinedGroupMember user gInfo m {memberStatus = GSMemConnected}
|
|
let Connection {viaUserContactLink} = conn
|
|
when (isJust viaUserContactLink && isNothing (memberContactId m)) sendXGrpLinkMem
|
|
members <- withStore' $ \db -> getGroupMembers db vr user gInfo
|
|
void . sendGroupMessage user gInfo members . XGrpMemNew $ memberInfo m
|
|
sendIntroductions members
|
|
when (groupFeatureAllowed SGFHistory gInfo) sendHistory
|
|
when (connChatVersion < batchSend2Version) sendGroupAutoReply
|
|
where
|
|
sendXGrpLinkMem = do
|
|
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
|
profileToSend = profileToSendOnAccept user profileMode True
|
|
void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend) groupId
|
|
sendIntroductions members = do
|
|
intros <- withStore' $ \db -> createIntroductions db (maxVersion vr) members m
|
|
shuffledIntros <- liftIO $ shuffleIntros intros
|
|
if m `supportsVersion` batchSendVersion
|
|
then do
|
|
let events = map (memberIntro . reMember) shuffledIntros
|
|
forM_ (L.nonEmpty events) $ \events' ->
|
|
sendGroupMemberMessages user conn events' groupId
|
|
else forM_ shuffledIntros $ \intro ->
|
|
processIntro intro `catchChatError` (toView . CRChatError (Just user))
|
|
memberIntro :: GroupMember -> ChatMsgEvent 'Json
|
|
memberIntro reMember =
|
|
let mInfo = memberInfo reMember
|
|
mRestrictions = memberRestrictions reMember
|
|
in XGrpMemIntro mInfo mRestrictions
|
|
shuffleIntros :: [GroupMemberIntro] -> IO [GroupMemberIntro]
|
|
shuffleIntros intros = do
|
|
let (admins, others) = partition isAdmin intros
|
|
(admPics, admNoPics) = partition hasPicture admins
|
|
(othPics, othNoPics) = partition hasPicture others
|
|
mconcat <$> mapM shuffle [admPics, admNoPics, othPics, othNoPics]
|
|
where
|
|
isAdmin GroupMemberIntro {reMember = GroupMember {memberRole}} = memberRole >= GRAdmin
|
|
hasPicture GroupMemberIntro {reMember = GroupMember {memberProfile = LocalProfile {image}}} = isJust image
|
|
processIntro intro@GroupMemberIntro {introId} = do
|
|
void $ sendDirectMemberMessage conn (memberIntro $ reMember intro) groupId
|
|
withStore' $ \db -> updateIntroStatus db introId GMIntroSent
|
|
sendHistory =
|
|
when (m `supportsVersion` batchSendVersion) $ do
|
|
(errs, items) <- partitionEithers <$> withStore' (\db -> getGroupHistoryItems db user gInfo m 100)
|
|
(errs', events) <- partitionEithers <$> mapM (tryChatError . itemForwardEvents) items
|
|
let errors = map ChatErrorStore errs <> errs'
|
|
unless (null errors) $ toView $ CRChatErrors (Just user) errors
|
|
let events' = maybe (concat events) (\x -> concat events <> [x]) descrEvent_
|
|
forM_ (L.nonEmpty events') $ \events'' ->
|
|
sendGroupMemberMessages user conn events'' groupId
|
|
descrEvent_ :: Maybe (ChatMsgEvent 'Json)
|
|
descrEvent_
|
|
| m `supportsVersion` groupHistoryIncludeWelcomeVersion = do
|
|
let GroupInfo {groupProfile = GroupProfile {description}} = gInfo
|
|
fmap (\descr -> XMsgNew $ MCSimple $ extMsgContent (MCText descr) Nothing) description
|
|
| otherwise = Nothing
|
|
itemForwardEvents :: CChatItem 'CTGroup -> CM [ChatMsgEvent 'Json]
|
|
itemForwardEvents cci = case cci of
|
|
(CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv sender, content = CIRcvMsgContent mc, file})
|
|
| not (blockedByAdmin sender) -> do
|
|
fInvDescr_ <- join <$> forM file getRcvFileInvDescr
|
|
processContentItem sender ci mc fInvDescr_
|
|
(CChatItem SMDSnd ci@ChatItem {content = CISndMsgContent mc, file}) -> do
|
|
fInvDescr_ <- join <$> forM file getSndFileInvDescr
|
|
processContentItem membership ci mc fInvDescr_
|
|
_ -> pure []
|
|
where
|
|
getRcvFileInvDescr :: CIFile 'MDRcv -> CM (Maybe (FileInvitation, RcvFileDescrText))
|
|
getRcvFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do
|
|
expired <- fileExpired
|
|
if fileProtocol /= FPXFTP || fileStatus == CIFSRcvCancelled || expired
|
|
then pure Nothing
|
|
else do
|
|
rfd <- withStore $ \db -> getRcvFileDescrByRcvFileId db fileId
|
|
pure $ invCompleteDescr ciFile rfd
|
|
getSndFileInvDescr :: CIFile 'MDSnd -> CM (Maybe (FileInvitation, RcvFileDescrText))
|
|
getSndFileInvDescr ciFile@CIFile {fileId, fileProtocol, fileStatus} = do
|
|
expired <- fileExpired
|
|
if fileProtocol /= FPXFTP || fileStatus == CIFSSndCancelled || expired
|
|
then pure Nothing
|
|
else do
|
|
-- can also lookup in extra_xftp_file_descriptions, though it can be empty;
|
|
-- would be best if snd file had a single rcv description for all members saved in files table
|
|
rfd <- withStore $ \db -> getRcvFileDescrBySndFileId db fileId
|
|
pure $ invCompleteDescr ciFile rfd
|
|
fileExpired :: CM Bool
|
|
fileExpired = do
|
|
ttl <- asks $ rcvFilesTTL . agentConfig . config
|
|
cutoffTs <- addUTCTime (-ttl) <$> liftIO getCurrentTime
|
|
pure $ chatItemTs cci < cutoffTs
|
|
invCompleteDescr :: CIFile d -> RcvFileDescr -> Maybe (FileInvitation, RcvFileDescrText)
|
|
invCompleteDescr CIFile {fileName, fileSize} RcvFileDescr {fileDescrText, fileDescrComplete}
|
|
| fileDescrComplete =
|
|
let fInvDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False}
|
|
fInv = xftpFileInvitation fileName fileSize fInvDescr
|
|
in Just (fInv, fileDescrText)
|
|
| otherwise = Nothing
|
|
processContentItem :: GroupMember -> ChatItem 'CTGroup d -> MsgContent -> Maybe (FileInvitation, RcvFileDescrText) -> CM [ChatMsgEvent 'Json]
|
|
processContentItem sender ChatItem {meta, quotedItem} mc fInvDescr_ =
|
|
if isNothing fInvDescr_ && not (msgContentHasText mc)
|
|
then pure []
|
|
else do
|
|
let CIMeta {itemTs, itemSharedMsgId, itemTimed} = meta
|
|
quotedItemId_ = quoteItemId =<< quotedItem
|
|
fInv_ = fst <$> fInvDescr_
|
|
-- TODO [mentions] history?
|
|
let (_t, ft_) = msgContentTexts mc
|
|
(msgContainer, _, _) <- withStore $ \db -> prepareGroupMsg db user gInfo mc ft_ M.empty quotedItemId_ Nothing fInv_ itemTimed False
|
|
let senderVRange = memberChatVRange' sender
|
|
xMsgNewChatMsg = ChatMessage {chatVRange = senderVRange, msgId = itemSharedMsgId, chatMsgEvent = XMsgNew msgContainer}
|
|
fileDescrEvents <- case (snd <$> fInvDescr_, itemSharedMsgId) of
|
|
(Just fileDescrText, Just msgId) -> do
|
|
partSize <- asks $ xftpDescrPartSize . config
|
|
let parts = splitFileDescr partSize fileDescrText
|
|
pure . L.toList $ L.map (XMsgFileDescr msgId) parts
|
|
_ -> pure []
|
|
let fileDescrChatMsgs = map (ChatMessage senderVRange Nothing) fileDescrEvents
|
|
GroupMember {memberId} = sender
|
|
msgForwardEvents = map (\cm -> XGrpMsgForward memberId cm itemTs) (xMsgNewChatMsg : fileDescrChatMsgs)
|
|
pure msgForwardEvents
|
|
_ -> do
|
|
let memCategory = memberCategory m
|
|
withStore' (\db -> getViaGroupContact db vr user m) >>= \case
|
|
Nothing -> do
|
|
notifyMemberConnected gInfo m Nothing
|
|
let connectedIncognito = memberIncognito membership
|
|
when (memCategory == GCPreMember) $ probeMatchingMemberContact m connectedIncognito
|
|
Just ct@Contact {activeConn} ->
|
|
forM_ activeConn $ \Connection {connStatus} ->
|
|
when (connStatus == ConnReady) $ do
|
|
notifyMemberConnected gInfo m $ Just ct
|
|
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
|
|
when (memCategory == GCPreMember) $ probeMatchingContactsAndMembers ct connectedIncognito True
|
|
sendXGrpMemCon memCategory
|
|
where
|
|
GroupMember {memberId} = m
|
|
sendXGrpMemCon = \case
|
|
GCPreMember ->
|
|
forM_ (invitedByGroupMemberId membership) $ \hostId -> do
|
|
host <- withStore $ \db -> getGroupMember db vr user groupId hostId
|
|
forM_ (memberConn host) $ \hostConn ->
|
|
void $ sendDirectMemberMessage hostConn (XGrpMemCon memberId) groupId
|
|
GCPostMember ->
|
|
forM_ (invitedByGroupMemberId m) $ \invitingMemberId -> do
|
|
im <- withStore $ \db -> getGroupMember db vr user groupId invitingMemberId
|
|
forM_ (memberConn im) $ \imConn ->
|
|
void $ sendDirectMemberMessage imConn (XGrpMemCon memberId) groupId
|
|
_ -> messageWarning "sendXGrpMemCon: member category GCPreMember or GCPostMember is expected"
|
|
MSG msgMeta _msgFlags msgBody -> do
|
|
tags <- newTVarIO []
|
|
withAckMessage "group msg" agentConnId msgMeta True (Just tags) $ \eInfo -> do
|
|
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
|
|
forM_ aChatMsgs $ \case
|
|
Right (ACMsg _ chatMsg) ->
|
|
processEvent tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e
|
|
Left e -> do
|
|
atomically $ modifyTVar' tags ("error" :)
|
|
logInfo $ "group msg=error " <> eInfo <> " " <> tshow e
|
|
toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e)
|
|
forwardMsgs (rights aChatMsgs) `catchChatError` (toView . CRChatError (Just user))
|
|
checkSendRcpt $ rights aChatMsgs
|
|
where
|
|
aChatMsgs = parseChatMessages msgBody
|
|
brokerTs = metaBrokerTs msgMeta
|
|
processEvent :: TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
|
|
processEvent tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do
|
|
let tag = toCMEventTag chatMsgEvent
|
|
atomically $ modifyTVar' tags (tshow tag :)
|
|
logInfo $ "group msg=" <> tshow tag <> " " <> eInfo
|
|
(m', conn', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m conn msgMeta msgBody chatMsg
|
|
case event of
|
|
XMsgNew mc -> memberCanSend m' $ newGroupContentMessage gInfo m' mc msg brokerTs False
|
|
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr
|
|
XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent mentions msg brokerTs ttl live
|
|
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg brokerTs
|
|
XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg brokerTs
|
|
-- TODO discontinue XFile
|
|
XFile fInv -> processGroupFileInvitation' gInfo m' fInv msg brokerTs
|
|
XFileCancel sharedMsgId -> xFileCancelGroup gInfo m' sharedMsgId
|
|
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo m' sharedMsgId fileConnReq_ fName
|
|
XInfo p -> xInfoMember gInfo m' p brokerTs
|
|
XGrpLinkMem p -> xGrpLinkMem gInfo m' conn' p
|
|
XGrpMemNew memInfo -> xGrpMemNew gInfo m' memInfo msg brokerTs
|
|
XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo m' memInfo memRestrictions_
|
|
XGrpMemInv memId introInv -> xGrpMemInv gInfo m' memId introInv
|
|
XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo m' memInfo introInv
|
|
XGrpMemRole memId memRole -> xGrpMemRole gInfo m' memId memRole msg brokerTs
|
|
XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo m' memId memRestrictions msg brokerTs
|
|
XGrpMemCon memId -> xGrpMemCon gInfo m' memId
|
|
XGrpMemDel memId -> xGrpMemDel gInfo m' memId msg brokerTs
|
|
XGrpLeave -> xGrpLeave gInfo m' msg brokerTs
|
|
XGrpDel -> xGrpDel gInfo m' msg brokerTs
|
|
XGrpInfo p' -> xGrpInfo gInfo m' p' msg brokerTs
|
|
XGrpPrefs ps' -> xGrpPrefs gInfo m' ps'
|
|
XGrpDirectInv connReq mContent_ -> memberCanSend m' $ xGrpDirectInv gInfo m' conn' connReq mContent_ msg brokerTs
|
|
XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo m' memberId msg' msgTs
|
|
XInfoProbe probe -> xInfoProbe (COMGroupMember m') probe
|
|
XInfoProbeCheck probeHash -> xInfoProbeCheck (COMGroupMember m') probeHash
|
|
XInfoProbeOk probe -> xInfoProbeOk (COMGroupMember m') probe
|
|
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo sharedMsgId chunk msgMeta
|
|
_ -> messageError $ "unsupported message: " <> tshow event
|
|
checkSendRcpt :: [AChatMessage] -> CM Bool
|
|
checkSendRcpt aMsgs = do
|
|
currentMemCount <- withStore' $ \db -> getGroupCurrentMembersCount db user gInfo
|
|
let GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo
|
|
pure $
|
|
fromMaybe (sendRcptsSmallGroups user) sendRcpts
|
|
&& any aChatMsgHasReceipt aMsgs
|
|
&& currentMemCount <= smallGroupsRcptsMemLimit
|
|
where
|
|
aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) =
|
|
hasDeliveryReceipt (toCMEventTag chatMsgEvent)
|
|
forwardMsgs :: [AChatMessage] -> CM ()
|
|
forwardMsgs aMsgs = do
|
|
let GroupMember {memberRole = membershipMemRole} = membership
|
|
when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ do
|
|
let forwardedMsgs = mapMaybe (\(ACMsg _ chatMsg) -> forwardedGroupMsg chatMsg) aMsgs
|
|
forM_ (L.nonEmpty forwardedMsgs) $ \forwardedMsgs' -> do
|
|
ChatConfig {highlyAvailable} <- asks config
|
|
-- members introduced to this invited member
|
|
introducedMembers <-
|
|
if memberCategory m == GCInviteeMember
|
|
then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable
|
|
else pure []
|
|
-- invited members to which this member was introduced
|
|
invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable
|
|
let GroupMember {memberId} = m
|
|
ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs'
|
|
events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs'
|
|
unless (null ms) $ void $ sendGroupMessages user gInfo ms events
|
|
RCVD msgMeta msgRcpt ->
|
|
withAckMessage' "group rcvd" agentConnId msgMeta $
|
|
groupMsgReceived gInfo m conn msgMeta msgRcpt
|
|
SENT msgId proxy -> do
|
|
continued <- continueSending connEntity conn
|
|
sentMsgDeliveryEvent conn msgId
|
|
checkSndInlineFTComplete conn msgId
|
|
updateGroupItemsStatus gInfo m conn msgId GSSSent (Just $ isJust proxy)
|
|
when continued $ sendPendingGroupMessages user m conn
|
|
SWITCH qd phase cStats -> do
|
|
toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats)
|
|
when (phase == SPStarted || phase == SPCompleted) $ case qd of
|
|
QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing
|
|
QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing
|
|
RSYNC rss cryptoErr_ cStats ->
|
|
case (rss, connectionCode, cryptoErr_) of
|
|
(RSRequired, _, Just cryptoErr) -> processErr cryptoErr
|
|
(RSAllowed, _, Just cryptoErr) -> processErr cryptoErr
|
|
(RSAgreed, Just _, _) -> do
|
|
withStore' $ \db -> setConnectionVerified db user connId Nothing
|
|
let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember
|
|
ratchetSyncEventItem m'
|
|
toView $ CRGroupMemberVerificationReset user gInfo m'
|
|
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing
|
|
_ -> ratchetSyncEventItem m
|
|
where
|
|
processErr cryptoErr = do
|
|
let e@(mde, n) = agentMsgDecryptError cryptoErr
|
|
ci_ <- withStore $ \db ->
|
|
getGroupMemberChatItemLast db user groupId (groupMemberId' m)
|
|
>>= liftIO
|
|
. mapM (\(ci, content') -> updateGroupChatItem db user groupId ci content' False False Nothing)
|
|
. mdeUpdatedCI e
|
|
case ci_ of
|
|
Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci)
|
|
_ -> do
|
|
toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats)
|
|
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing
|
|
ratchetSyncEventItem m' = do
|
|
toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats)
|
|
createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing
|
|
OK ->
|
|
-- [async agent commands] continuation on receiving OK
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
JOINED sqSecured ->
|
|
-- [async agent commands] continuation on receiving JOINED
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData ->
|
|
when (sqSecured && connChatVersion >= batchSend2Version) sendGroupAutoReply
|
|
QCONT -> do
|
|
continued <- continueSending connEntity conn
|
|
when continued $ sendPendingGroupMessages user m conn
|
|
MWARN msgId err -> do
|
|
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSWarning $ agentSndError err)
|
|
processConnMWARN connEntity conn err
|
|
MERR msgId err -> do
|
|
withStore' $ \db -> updateGroupItemsErrorStatus db msgId (groupMemberId' m) (GSSError $ agentSndError err)
|
|
-- group errors are silenced to reduce load on UI event log
|
|
-- toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
processConnMERR connEntity conn err
|
|
MERRS msgIds err -> do
|
|
let newStatus = GSSError $ agentSndError err
|
|
-- error cannot be AUTH error here
|
|
withStore' $ \db -> forM_ msgIds $ \msgId ->
|
|
updateGroupItemsErrorStatus db msgId (groupMemberId' m) newStatus `catchAll_` pure ()
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
where
|
|
updateGroupItemsErrorStatus :: DB.Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO ()
|
|
updateGroupItemsErrorStatus db msgId groupMemberId newStatus = do
|
|
itemIds <- getChatItemIdsByAgentMsgId db connId msgId
|
|
forM_ itemIds $ \itemId -> updateGroupMemSndStatus' db itemId groupMemberId newStatus
|
|
sendGroupAutoReply = autoReplyMC >>= mapM_ send
|
|
where
|
|
autoReplyMC = do
|
|
let GroupInfo {businessChat} = gInfo
|
|
GroupMember {memberId = joiningMemberId} = m
|
|
case businessChat of
|
|
Just BusinessChatInfo {customerId, chatType = BCCustomer}
|
|
| joiningMemberId == customerId -> useReply <$> withStore (`getUserAddress` user)
|
|
where
|
|
useReply UserContactLink {autoAccept} = case autoAccept of
|
|
Just AutoAccept {businessAddress, autoReply} | businessAddress -> autoReply
|
|
_ -> Nothing
|
|
_ -> pure Nothing
|
|
send mc = do
|
|
msg <- sendGroupMessage' user gInfo [m] (XMsgNew $ MCSimple (extMsgContent mc Nothing))
|
|
ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndMsgContent mc)
|
|
withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew
|
|
toView $ CRNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci]
|
|
|
|
agentMsgDecryptError :: AgentCryptoError -> (MsgDecryptError, Word32)
|
|
agentMsgDecryptError = \case
|
|
DECRYPT_AES -> (MDEOther, 1)
|
|
DECRYPT_CB -> (MDEOther, 1)
|
|
RATCHET_HEADER -> (MDERatchetHeader, 1)
|
|
RATCHET_EARLIER _ -> (MDERatchetEarlier, 1)
|
|
RATCHET_SKIPPED n -> (MDETooManySkipped, n)
|
|
RATCHET_SYNC -> (MDERatchetSync, 0)
|
|
|
|
mdeUpdatedCI :: (MsgDecryptError, Word32) -> CChatItem c -> Maybe (ChatItem c 'MDRcv, CIContent 'MDRcv)
|
|
mdeUpdatedCI (mde', n') (CChatItem _ ci@ChatItem {content = CIRcvDecryptionError mde n})
|
|
| mde == mde' = case mde of
|
|
MDERatchetHeader -> r (n + n')
|
|
MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1
|
|
MDERatchetEarlier -> r (n + n')
|
|
MDEOther -> r (n + n')
|
|
MDERatchetSync -> r 0
|
|
| otherwise = Nothing
|
|
where
|
|
r n'' = Just (ci, CIRcvDecryptionError mde n'')
|
|
mdeUpdatedCI _ _ = Nothing
|
|
|
|
processSndFileConn :: AEvent e -> ConnectionEntity -> Connection -> SndFileTransfer -> CM ()
|
|
processSndFileConn agentMsg connEntity conn ft@SndFileTransfer {fileId, fileName, fileStatus} =
|
|
case agentMsg of
|
|
-- SMP CONF for SndFileConnection happens for direct file protocol
|
|
-- when recipient of the file "joins" connection created by the sender
|
|
CONF confId _pqSupport _ connInfo -> do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
conn' <- updatePeerChatVRange conn chatVRange
|
|
case chatMsgEvent of
|
|
-- TODO save XFileAcpt message
|
|
XFileAcpt name
|
|
| name == fileName -> do
|
|
withStore' $ \db -> updateSndFileStatus db ft FSAccepted
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
allowAgentConnectionAsync user conn' confId XOk
|
|
| otherwise -> messageError "x.file.acpt: fileName is different from expected"
|
|
_ -> messageError "CONF from file connection must have x.file.acpt"
|
|
CON _ -> do
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ updateSndFileStatus db ft FSConnected
|
|
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
|
toView $ CRSndFileStart user ci ft
|
|
sendFileChunk user ft
|
|
SENT msgId _proxy -> do
|
|
withStore' $ \db -> updateSndFileChunkSent db ft msgId
|
|
unless (fileStatus == FSCancelled) $ sendFileChunk user ft
|
|
MERR _ err -> do
|
|
cancelSndFileTransfer user ft True >>= mapM_ (deleteAgentConnectionAsync user)
|
|
case err of
|
|
SMP _ SMP.AUTH -> unless (fileStatus == FSCancelled) $ do
|
|
ci <- withStore $ \db -> do
|
|
liftIO (lookupChatRefByFileId db user fileId) >>= \case
|
|
Just (ChatRef CTDirect _) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
|
|
_ -> pure ()
|
|
lookupChatItemByFileId db vr user fileId
|
|
toView $ CRSndFileRcvCancelled user ci ft
|
|
_ -> throwChatError $ CEFileSend fileId err
|
|
MSG meta _ _ ->
|
|
withAckMessage' "file msg" agentConnId meta $ pure ()
|
|
OK ->
|
|
-- [async agent commands] continuation on receiving OK
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
JOINED _ ->
|
|
-- [async agent commands] continuation on receiving JOINED
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
|
|
processRcvFileConn :: AEvent e -> ConnectionEntity -> Connection -> RcvFileTransfer -> CM ()
|
|
processRcvFileConn agentMsg connEntity conn ft@RcvFileTransfer {fileId, fileInvitation = FileInvitation {fileName}, grpMemberId} =
|
|
case agentMsg of
|
|
INV (ACR _ cReq) ->
|
|
withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} ->
|
|
case cReq of
|
|
fileInvConnReq@(CRInvitationUri _ _) -> case cmdFunction of
|
|
-- [async agent commands] direct XFileAcptInv continuation on receiving INV
|
|
CFCreateConnFileInvDirect -> do
|
|
ct <- withStore $ \db -> getContactByFileId db vr user fileId
|
|
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
|
void $ sendDirectContactMessage user ct (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName)
|
|
-- [async agent commands] group XFileAcptInv continuation on receiving INV
|
|
CFCreateConnFileInvGroup -> case grpMemberId of
|
|
Just gMemberId -> do
|
|
GroupMember {groupId, activeConn} <- withStore $ \db -> getGroupMemberById db vr user gMemberId
|
|
case activeConn of
|
|
Just gMemberConn -> do
|
|
sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId
|
|
void $ sendDirectMemberMessage gMemberConn (XFileAcptInv sharedMsgId (Just fileInvConnReq) fileName) groupId
|
|
_ -> throwChatError $ CECommandError "no GroupMember activeConn"
|
|
_ -> throwChatError $ CECommandError "no grpMemberId"
|
|
_ -> throwChatError $ CECommandError "unexpected cmdFunction"
|
|
CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type"
|
|
-- SMP CONF for RcvFileConnection happens for group file protocol
|
|
-- when sender of the file "joins" connection created by the recipient
|
|
-- (sender doesn't create connections for all group members)
|
|
CONF confId _pqSupport _ connInfo -> do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
conn' <- updatePeerChatVRange conn chatVRange
|
|
case chatMsgEvent of
|
|
XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
_ -> pure ()
|
|
CON _ -> startReceivingFile user fileId
|
|
MSG meta _ msgBody -> do
|
|
-- XXX: not all branches do ACK
|
|
parseFileChunk msgBody >>= receiveFileChunk ft (Just conn) meta
|
|
OK ->
|
|
-- [async agent commands] continuation on receiving OK
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
JOINED _ ->
|
|
-- [async agent commands] continuation on receiving JOINED
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
MERR _ err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
processConnMERR connEntity conn err
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
|
|
receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
|
|
receiveFileChunk ft@RcvFileTransfer {fileId, chunkSize} conn_ meta@MsgMeta {recipient = (msgId, _), integrity} = \case
|
|
FileChunkCancel ->
|
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
|
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
|
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileSndCancelled user ci ft
|
|
FileChunk {chunkNo, chunkBytes = chunk} -> do
|
|
case integrity of
|
|
MsgOk -> pure ()
|
|
MsgError MsgDuplicate -> pure () -- TODO remove once agent removes duplicates
|
|
MsgError e ->
|
|
badRcvFileChunk ft $ "invalid file chunk number " <> show chunkNo <> ": " <> show e
|
|
withStore' (\db -> createRcvFileChunk db ft chunkNo msgId) >>= \case
|
|
RcvChunkOk ->
|
|
if B.length chunk /= fromInteger chunkSize
|
|
then badRcvFileChunk ft "incorrect chunk size"
|
|
else withAckMessage' "file msg" agentConnId meta $ appendFileChunk ft chunkNo chunk False
|
|
RcvChunkFinal ->
|
|
if B.length chunk > fromInteger chunkSize
|
|
then badRcvFileChunk ft "incorrect chunk size"
|
|
else do
|
|
appendFileChunk ft chunkNo chunk True
|
|
ci <- withStore $ \db -> do
|
|
liftIO $ do
|
|
updateRcvFileStatus db fileId FSComplete
|
|
updateCIFileStatus db user fileId CIFSRcvComplete
|
|
deleteRcvFileChunks db ft
|
|
getChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileComplete user ci
|
|
forM_ conn_ $ \conn -> deleteAgentConnectionAsync user (aConnId conn)
|
|
RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure ()
|
|
RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo
|
|
|
|
processUserContactRequest :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
|
|
processUserContactRequest agentMsg connEntity conn UserContact {userContactLinkId} = case agentMsg of
|
|
REQ invId pqSupport _ connInfo -> do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo
|
|
case chatMsgEvent of
|
|
XContact p xContactId_ -> profileContactRequest invId chatVRange p xContactId_ pqSupport
|
|
XInfo p -> profileContactRequest invId chatVRange p Nothing pqSupport
|
|
-- TODO show/log error, other events in contact request
|
|
_ -> pure ()
|
|
MERR _ err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
processConnMERR connEntity conn err
|
|
ERR err -> do
|
|
toView $ CRChatError (Just user) (ChatErrorAgent err $ Just connEntity)
|
|
when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure ()
|
|
-- TODO add debugging output
|
|
_ -> pure ()
|
|
where
|
|
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> PQSupport -> CM ()
|
|
profileContactRequest invId chatVRange p xContactId_ reqPQSup = do
|
|
withStore (\db -> createOrUpdateContactRequest db vr user userContactLinkId invId chatVRange p xContactId_ reqPQSup) >>= \case
|
|
CORContact contact -> toView $ CRContactRequestAlreadyAccepted user contact
|
|
CORGroup gInfo -> toView $ CRBusinessRequestAlreadyAccepted user gInfo
|
|
CORRequest cReq -> do
|
|
ucl <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId
|
|
let (UserContactLink {connReqContact, autoAccept}, groupId_, gLinkMemRole) = ucl
|
|
isSimplexTeam = sameConnReqContact connReqContact adminContactReq
|
|
v = maxVersion chatVRange
|
|
case autoAccept of
|
|
Just AutoAccept {acceptIncognito, businessAddress}
|
|
| businessAddress ->
|
|
if v < groupFastLinkJoinVersion || (isSimplexTeam && v < businessChatsVersion)
|
|
then do
|
|
ct <- acceptContactRequestAsync user cReq Nothing True reqPQSup
|
|
toView $ CRAcceptingContactRequest user ct
|
|
else do
|
|
gInfo <- acceptBusinessJoinRequestAsync user cReq
|
|
toView $ CRAcceptingBusinessRequest user gInfo
|
|
| otherwise -> case groupId_ of
|
|
Nothing -> do
|
|
-- [incognito] generate profile to send, create connection with incognito profile
|
|
incognitoProfile <- if acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing
|
|
ct <- acceptContactRequestAsync user cReq incognitoProfile True reqPQSup
|
|
toView $ CRAcceptingContactRequest user ct
|
|
Just groupId -> do
|
|
gInfo <- withStore $ \db -> getGroupInfo db vr user groupId
|
|
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo
|
|
if v >= groupFastLinkJoinVersion
|
|
then do
|
|
mem <- acceptGroupJoinRequestAsync user gInfo cReq gLinkMemRole profileMode
|
|
createInternalChatItem user (CDGroupRcv gInfo mem) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing
|
|
toView $ CRAcceptingGroupJoinRequestMember user gInfo mem
|
|
else do
|
|
-- TODO v5.7 remove old API (or v6.0?)
|
|
ct <- acceptContactRequestAsync user cReq profileMode False PQSupportOff
|
|
toView $ CRAcceptingGroupJoinRequest user gInfo ct
|
|
_ -> toView $ CRReceivedContactRequest user cReq
|
|
|
|
memberCanSend :: GroupMember -> CM () -> CM ()
|
|
memberCanSend GroupMember {memberRole} a
|
|
| memberRole <= GRObserver = messageError "member is not allowed to send messages"
|
|
| otherwise = a
|
|
|
|
processConnMERR :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
|
|
processConnMERR connEntity conn err = do
|
|
case err of
|
|
SMP _ SMP.AUTH -> do
|
|
authErrCounter' <- withStore' $ \db -> incAuthErrCounter db user conn
|
|
when (authErrCounter' >= authErrDisableCount) $ case connEntity of
|
|
RcvDirectMsgConnection ctConn (Just ct) -> do
|
|
toView $ CRContactDisabled user ct {activeConn = Just ctConn {authErrCounter = authErrCounter'}}
|
|
_ -> toView $ CRConnectionDisabled connEntity
|
|
SMP _ SMP.QUOTA ->
|
|
unless (connInactive conn) $ do
|
|
withStore' $ \db -> setQuotaErrCounter db user conn quotaErrSetOnMERR
|
|
toView $ CRConnectionInactive connEntity True
|
|
_ -> pure ()
|
|
|
|
processConnMWARN :: ConnectionEntity -> Connection -> AgentErrorType -> CM ()
|
|
processConnMWARN connEntity conn err = do
|
|
case err of
|
|
SMP _ SMP.QUOTA ->
|
|
unless (connInactive conn) $ do
|
|
quotaErrCounter' <- withStore' $ \db -> incQuotaErrCounter db user conn
|
|
when (quotaErrCounter' >= quotaErrInactiveCount) $
|
|
toView $
|
|
CRConnectionInactive connEntity True
|
|
_ -> pure ()
|
|
|
|
continueSending :: ConnectionEntity -> Connection -> CM Bool
|
|
continueSending connEntity conn =
|
|
if connInactive conn
|
|
then do
|
|
withStore' $ \db -> setQuotaErrCounter db user conn 0
|
|
toView $ CRConnectionInactive connEntity False
|
|
pure True
|
|
else pure False
|
|
|
|
-- TODO v5.7 / v6.0 - together with deprecating old group protocol establishing direct connections?
|
|
-- we could save command records only for agent APIs we process continuations for (INV)
|
|
withCompletedCommand :: forall e. AEntityI e => Connection -> AEvent e -> (CommandData -> CM ()) -> CM ()
|
|
withCompletedCommand Connection {connId} agentMsg action = do
|
|
let agentMsgTag = AEvtTag (sAEntity @e) $ aEventTag agentMsg
|
|
cmdData_ <- withStore' $ \db -> getCommandDataByCorrId db user corrId
|
|
case cmdData_ of
|
|
Just cmdData@CommandData {cmdId, cmdConnId = Just cmdConnId', cmdFunction}
|
|
| connId == cmdConnId' && (agentMsgTag == commandExpectedResponse cmdFunction || agentMsgTag == AEvtTag SAEConn ERR_) -> do
|
|
withStore' $ \db -> deleteCommand db user cmdId
|
|
action cmdData
|
|
| otherwise -> err cmdId $ "not matching connection id or unexpected response, corrId = " <> show corrId
|
|
Just CommandData {cmdId, cmdConnId = Nothing} -> err cmdId $ "no command connection id, corrId = " <> show corrId
|
|
Nothing -> throwChatError . CEAgentCommandError $ "command not found, corrId = " <> show corrId
|
|
where
|
|
err cmdId msg = do
|
|
withStore' $ \db -> updateCommandStatus db user cmdId CSError
|
|
throwChatError . CEAgentCommandError $ msg
|
|
|
|
withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM ()
|
|
withAckMessage' label cId msgMeta action = do
|
|
withAckMessage label cId msgMeta False Nothing $ \_ -> action $> False
|
|
|
|
withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM Bool) -> CM ()
|
|
withAckMessage label cId msgMeta showCritical tags action = do
|
|
-- [async agent commands] command should be asynchronous
|
|
-- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user).
|
|
-- Possible solutions are:
|
|
-- 1) retry processing several times
|
|
-- 2) stabilize database
|
|
-- 3) show screen of death to the user asking to restart
|
|
eInfo <- eventInfo
|
|
logInfo $ label <> ": " <> eInfo
|
|
tryChatError (action eInfo) >>= \case
|
|
Right withRcpt ->
|
|
withLog (eInfo <> " ok") $ ackMsg msgMeta $ if withRcpt then Just "" else Nothing
|
|
-- If showCritical is True, then these errors don't result in ACK and show user visible alert
|
|
-- This prevents losing the message that failed to be processed.
|
|
Left (ChatErrorStore SEDBBusyError {message}) | showCritical -> throwError $ ChatErrorAgent (CRITICAL True message) Nothing
|
|
Left e -> do
|
|
withLog (eInfo <> " error: " <> tshow e) $ ackMsg msgMeta Nothing
|
|
throwError e
|
|
where
|
|
eventInfo = do
|
|
v <- asks eventSeq
|
|
eId <- atomically $ stateTVar v $ \i -> (i + 1, i + 1)
|
|
pure $ "conn_id=" <> tshow cId <> " event_id=" <> tshow eId
|
|
withLog eInfo' ack = do
|
|
ts <- showTags
|
|
logInfo $ T.unwords [label, "ack:", ts, eInfo']
|
|
ack
|
|
logInfo $ T.unwords [label, "ack=success:", ts, eInfo']
|
|
showTags = do
|
|
ts <- maybe (pure []) readTVarIO tags
|
|
pure $ case ts of
|
|
[] -> "no_chat_messages"
|
|
[t] -> "chat_message=" <> t
|
|
_ -> "chat_message_batch=" <> T.intercalate "," (reverse ts)
|
|
ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM ()
|
|
ackMsg MsgMeta {recipient = (msgId, _)} rcpt = withAgent $ \a -> ackMessageAsync a "" cId msgId rcpt
|
|
|
|
sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM ()
|
|
sentMsgDeliveryEvent Connection {connId} msgId =
|
|
withStore' $ \db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
|
|
|
|
agentSndError :: AgentErrorType -> SndError
|
|
agentSndError = \case
|
|
SMP _ AUTH -> SndErrAuth
|
|
SMP _ QUOTA -> SndErrQuota
|
|
BROKER _ e -> brokerError SndErrRelay e
|
|
SMP proxySrv (SMP.PROXY (SMP.BROKER e)) -> brokerError (SndErrProxy proxySrv) e
|
|
AP.PROXY proxySrv _ (ProxyProtocolError (SMP.PROXY (SMP.BROKER e))) -> brokerError (SndErrProxyRelay proxySrv) e
|
|
e -> SndErrOther $ tshow e
|
|
where
|
|
brokerError srvErr = \case
|
|
NETWORK -> SndErrExpired
|
|
TIMEOUT -> SndErrExpired
|
|
HOST -> srvErr SrvErrHost
|
|
SMP.TRANSPORT TEVersion -> srvErr SrvErrVersion
|
|
e -> srvErr . SrvErrOther $ tshow e
|
|
|
|
badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
|
|
badRcvFileChunk ft err =
|
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
|
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
|
throwChatError $ CEFileRcvChunk err
|
|
|
|
memberConnectedChatItem :: GroupInfo -> GroupMember -> CM ()
|
|
memberConnectedChatItem gInfo m =
|
|
-- ts should be broker ts but we don't have it for CON
|
|
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing
|
|
|
|
groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> CM ()
|
|
groupDescriptionChatItem gInfo m descr =
|
|
createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing
|
|
|
|
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM ()
|
|
notifyMemberConnected gInfo m ct_ = do
|
|
memberConnectedChatItem gInfo m
|
|
lift $ mapM_ (`setContactNetworkStatus` NSConnected) ct_
|
|
toView $ CRConnectedToGroupMember user gInfo m ct_
|
|
|
|
probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> CM ()
|
|
probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
|
|
gVar <- asks random
|
|
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
|
if contactMerge && not connectedIncognito
|
|
then do
|
|
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId (COMContact ct)
|
|
-- ! when making changes to probe-and-merge mechanism,
|
|
-- ! test scenario in which recipient receives probe after probe hashes (not covered in tests):
|
|
-- sendProbe -> sendProbeHashes (currently)
|
|
-- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay)
|
|
sendProbe probe
|
|
cs <-
|
|
if doProbeContacts
|
|
then map COMContact <$> withStore' (\db -> getMatchingContacts db vr user ct)
|
|
else pure []
|
|
ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct)
|
|
sendProbeHashes (cs <> ms) probe probeId
|
|
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
|
where
|
|
sendProbe :: Probe -> CM ()
|
|
sendProbe probe = void . sendDirectContactMessage user ct $ XInfoProbe probe
|
|
|
|
probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> CM ()
|
|
probeMatchingMemberContact GroupMember {activeConn = Nothing} _ = pure ()
|
|
probeMatchingMemberContact m@GroupMember {groupId, activeConn = Just conn} connectedIncognito = do
|
|
gVar <- asks random
|
|
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
|
if contactMerge && not connectedIncognito
|
|
then do
|
|
(probe, probeId) <- withStore $ \db -> createSentProbe db gVar userId $ COMGroupMember m
|
|
sendProbe probe
|
|
cs <- map COMContact <$> withStore' (\db -> getMatchingMemberContacts db vr user m)
|
|
sendProbeHashes cs probe probeId
|
|
else sendProbe . Probe =<< liftIO (encodedRandomBytes gVar 32)
|
|
where
|
|
sendProbe :: Probe -> CM ()
|
|
sendProbe probe = void $ sendDirectMemberMessage conn (XInfoProbe probe) groupId
|
|
|
|
sendProbeHashes :: [ContactOrMember] -> Probe -> Int64 -> CM ()
|
|
sendProbeHashes cgms probe probeId =
|
|
forM_ cgms $ \cgm -> sendProbeHash cgm `catchChatError` \_ -> pure ()
|
|
where
|
|
probeHash = ProbeHash $ C.sha256Hash (unProbe probe)
|
|
sendProbeHash :: ContactOrMember -> CM ()
|
|
sendProbeHash cgm@(COMContact c) = do
|
|
void . sendDirectContactMessage user c $ XInfoProbeCheck probeHash
|
|
withStore' $ \db -> createSentProbeHash db userId probeId cgm
|
|
sendProbeHash (COMGroupMember GroupMember {activeConn = Nothing}) = pure ()
|
|
sendProbeHash cgm@(COMGroupMember m@GroupMember {groupId, activeConn = Just conn}) =
|
|
when (memberCurrent m) $ do
|
|
void $ sendDirectMemberMessage conn (XInfoProbeCheck probeHash) groupId
|
|
withStore' $ \db -> createSentProbeHash db userId probeId cgm
|
|
|
|
messageWarning :: Text -> CM ()
|
|
messageWarning = toView . CRMessageError user "warning"
|
|
|
|
messageError :: Text -> CM ()
|
|
messageError = toView . CRMessageError user "error"
|
|
|
|
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
|
|
newContentMessage ct@Contact {contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do
|
|
unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct
|
|
let ExtMsgContent content _ fInv_ _ _ = mcExtMsgContent mc
|
|
-- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete
|
|
-- case content of
|
|
-- MCText "hello 111" ->
|
|
-- UE.throwIO $ userError "#####################"
|
|
-- -- throwChatError $ CECommandError "#####################"
|
|
-- _ -> pure ()
|
|
if isVoice content && not (featureAllowed SCFVoice forContact ct)
|
|
then do
|
|
void $ newChatItem (ciContentNoParse $ CIRcvChatFeatureRejected CFVoice) Nothing Nothing False
|
|
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
|
|
newChatItem (CIRcvMsgContent content, msgContentTexts content) (snd <$> file_) timed_ live
|
|
autoAcceptFile file_
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
newChatItem content ciFile_ timed_ live = do
|
|
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M.empty
|
|
reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getDirectCIReactions db ct sharedMsgId) sharedMsgId_
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci {reactions}]
|
|
|
|
autoAcceptFile :: Maybe (RcvFileTransfer, CIFile 'MDRcv) -> CM ()
|
|
autoAcceptFile = mapM_ $ \(ft, CIFile {fileSize}) -> do
|
|
-- ! autoAcceptFileSize is only used in tests
|
|
ChatConfig {autoAcceptFileSize = sz} <- asks config
|
|
when (sz > fileSize) $ receiveFile' user ft False Nothing Nothing >>= toView
|
|
|
|
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM ()
|
|
messageFileDescription ct@Contact {contactId} sharedMsgId fileDescr = do
|
|
fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
|
|
processFDMessage (CDDirectRcv ct) sharedMsgId fileId fileDescr
|
|
|
|
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM ()
|
|
groupMessageFileDescription g@GroupInfo {groupId} m sharedMsgId fileDescr = do
|
|
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
|
processFDMessage (CDGroupRcv g m) sharedMsgId fileId fileDescr
|
|
|
|
processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> CM ()
|
|
processFDMessage cd sharedMsgId fileId fileDescr = do
|
|
ft <- withStore $ \db -> getRcvFileTransfer db user fileId
|
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
|
(rfd@RcvFileDescr {fileDescrComplete}, ft'@RcvFileTransfer {fileStatus, xftpRcvFile, cryptoArgs}) <- withStore $ \db -> do
|
|
rfd <- appendRcvFD db userId fileId fileDescr
|
|
-- reading second time in the same transaction as appending description
|
|
-- to prevent race condition with accept
|
|
ft' <- getRcvFileTransfer db user fileId
|
|
pure (rfd, ft')
|
|
when fileDescrComplete $ do
|
|
ci <- withStore $ \db -> getAChatItemBySharedMsgId db user cd sharedMsgId
|
|
toView $ CRRcvFileDescrReady user ci ft' rfd
|
|
case (fileStatus, xftpRcvFile) of
|
|
(RFSAccepted _, Just XFTPRcvFile {userApprovedRelays}) -> receiveViaCompleteFD user fileId rfd userApprovedRelays cryptoArgs
|
|
_ -> pure ()
|
|
|
|
processFileInvitation :: Maybe FileInvitation -> MsgContent -> (DB.Connection -> FileInvitation -> Maybe InlineFileMode -> Integer -> ExceptT StoreError IO RcvFileTransfer) -> CM (Maybe (RcvFileTransfer, CIFile 'MDRcv))
|
|
processFileInvitation fInv_ mc createRcvFT = forM fInv_ $ \fInv' -> do
|
|
ChatConfig {fileChunkSize} <- asks config
|
|
let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv'
|
|
inline <- receiveInlineMode fInv (Just mc) fileChunkSize
|
|
ft@RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFT db fInv inline fileChunkSize
|
|
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
|
(filePath, fileStatus, ft') <- case inline of
|
|
Just IFMSent -> do
|
|
encrypt <- chatReadVar encryptLocalFiles
|
|
ft' <- (if encrypt then setFileToEncrypt else pure) ft
|
|
fPath <- getRcvFilePath fileId Nothing fileName True
|
|
withStore' $ \db -> startRcvInlineFT db user ft' fPath inline
|
|
pure (Just fPath, CIFSRcvAccepted, ft')
|
|
_ -> pure (Nothing, CIFSRcvInvitation, ft)
|
|
let RcvFileTransfer {cryptoArgs} = ft'
|
|
fileSource = (`CryptoFile` cryptoArgs) <$> filePath
|
|
pure (ft', CIFile {fileId, fileName, fileSize, fileSource, fileStatus, fileProtocol})
|
|
|
|
mkValidFileInvitation :: FileInvitation -> FileInvitation
|
|
mkValidFileInvitation fInv@FileInvitation {fileName} = fInv {fileName = FP.makeValid $ FP.takeFileName fileName}
|
|
|
|
messageUpdate :: Contact -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> CM ()
|
|
messageUpdate ct@Contact {contactId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl live_ = do
|
|
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).
|
|
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
|
let timed_ = rcvContactCITimed ct ttl
|
|
ts = ciContentTexts content
|
|
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live M.empty
|
|
ci' <- withStore' $ \db -> do
|
|
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
|
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
|
|
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
content = CIRcvMsgContent mc
|
|
live = fromMaybe False live_
|
|
updateRcvChatItem = do
|
|
cci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
|
|
case cci of
|
|
CChatItem SMDRcv ci@ChatItem {meta = CIMeta {itemForwarded, itemLive}, content = CIRcvMsgContent oldMC}
|
|
| isNothing itemForwarded -> do
|
|
let changed = mc /= oldMC
|
|
if changed || fromMaybe False itemLive
|
|
then do
|
|
ci' <- withStore' $ \db -> do
|
|
when changed $
|
|
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
|
|
reactions <- getDirectCIReactions db ct sharedMsgId
|
|
let edited = itemLive /= Just True
|
|
updateDirectChatItem' db user contactId ci {reactions} content edited live Nothing $ Just msgId
|
|
toView $ CRChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci')
|
|
startUpdatedTimedItemThread user (ChatRef CTDirect contactId) ci ci'
|
|
else toView $ CRChatItemNotChanged user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci)
|
|
_ -> messageError "x.msg.update: contact attempted invalid message update"
|
|
|
|
messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM ()
|
|
messageDelete ct@Contact {contactId} sharedMsgId _rcvMessage msgMeta = do
|
|
deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct)
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
deleteRcvChatItem = do
|
|
cci@(CChatItem msgDir ci) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
|
|
case msgDir of
|
|
SMDRcv
|
|
| rcvItemDeletable ci brokerTs ->
|
|
if featureAllowed SCFFullDelete forContact ct
|
|
then deleteDirectCIs user ct [cci] False False >>= toView
|
|
else markDirectCIsDeleted user ct [cci] False brokerTs >>= toView
|
|
| otherwise -> messageError "x.msg.del: contact attempted invalid message delete"
|
|
SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete"
|
|
|
|
rcvItemDeletable :: ChatItem c d -> UTCTime -> Bool
|
|
rcvItemDeletable ChatItem {meta = CIMeta {itemTs, itemDeleted}} brokerTs =
|
|
-- 78 hours margin to account for possible sending delay
|
|
diffUTCTime brokerTs itemTs < (78 * 3600) && isNothing itemDeleted
|
|
|
|
directMsgReaction :: Contact -> SharedMsgId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> CM ()
|
|
directMsgReaction ct sharedMsgId reaction add RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do
|
|
when (featureAllowed SCFReactions forContact ct) $ do
|
|
rs <- withStore' $ \db -> getDirectReactions db ct sharedMsgId False
|
|
when (reactionAllowed add reaction rs) $ do
|
|
updateChatItemReaction `catchCINotFound` \_ ->
|
|
withStore' $ \db -> setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs
|
|
where
|
|
updateChatItemReaction = do
|
|
cr_ <- withStore $ \db -> do
|
|
CChatItem md ci <- getDirectChatItemBySharedMsgId db user (contactId' ct) sharedMsgId
|
|
if ciReactionAllowed ci
|
|
then liftIO $ do
|
|
setDirectReaction db ct sharedMsgId False reaction add msgId brokerTs
|
|
reactions <- getDirectCIReactions db ct sharedMsgId
|
|
let ci' = CChatItem md ci {reactions}
|
|
r = ACIReaction SCTDirect SMDRcv (DirectChat ct) $ CIReaction CIDirectRcv ci' brokerTs reaction
|
|
pure $ Just $ CRChatItemReaction user add r
|
|
else pure Nothing
|
|
mapM_ toView cr_
|
|
|
|
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM ()
|
|
groupMsgReaction g@GroupInfo {groupId} m sharedMsgId itemMemberId reaction add RcvMessage {msgId} brokerTs = do
|
|
when (groupFeatureAllowed SGFReactions g) $ do
|
|
rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False
|
|
when (reactionAllowed add reaction rs) $ do
|
|
updateChatItemReaction `catchCINotFound` \_ ->
|
|
withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
|
|
where
|
|
updateChatItemReaction = do
|
|
cr_ <- withStore $ \db -> do
|
|
CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId
|
|
if ciReactionAllowed ci
|
|
then liftIO $ do
|
|
setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
|
|
reactions <- getGroupCIReactions db g itemMemberId sharedMsgId
|
|
let ci' = CChatItem md ci {reactions}
|
|
r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction
|
|
pure $ Just $ CRChatItemReaction user add r
|
|
else pure Nothing
|
|
mapM_ toView cr_
|
|
|
|
reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool
|
|
reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions)
|
|
|
|
catchCINotFound :: CM a -> (SharedMsgId -> CM a) -> CM a
|
|
catchCINotFound f handle =
|
|
f `catchChatError` \case
|
|
ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId
|
|
e -> throwError e
|
|
|
|
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
|
|
newGroupContentMessage gInfo m@GroupMember {memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded
|
|
| blockedByAdmin m = createBlockedByAdmin
|
|
| otherwise = case prohibitedGroupContent gInfo m content ft_ fInv_ of
|
|
Just f -> rejected f
|
|
Nothing ->
|
|
withStore' (\db -> getCIModeration db vr user gInfo memberId sharedMsgId_) >>= \case
|
|
Just ciModeration -> do
|
|
applyModeration ciModeration
|
|
withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_
|
|
Nothing -> createContentItem
|
|
where
|
|
rejected f = void $ newChatItem (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False
|
|
timed' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo itemTTL
|
|
live' = fromMaybe False live_
|
|
ExtMsgContent content mentions fInv_ itemTTL live_ = mcExtMsgContent mc
|
|
ts@(_, ft_) = msgContentTexts content
|
|
createBlockedByAdmin
|
|
| groupFeatureAllowed SGFFullDelete gInfo = do -- ignores member role when blocked by admin
|
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvBlocked) Nothing timed' False M.empty
|
|
ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo ci brokerTs
|
|
groupMsgToView gInfo ci'
|
|
| otherwise = do
|
|
file_ <- processFileInv
|
|
ci <- createNonLive file_
|
|
ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci
|
|
groupMsgToView gInfo ci'
|
|
applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt}
|
|
| moderatorRole < GRModerator || moderatorRole < memberRole =
|
|
createContentItem
|
|
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo = do
|
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (ciContentNoParse CIRcvModerated) Nothing timed' False M.empty
|
|
ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo ci moderator moderatedAt
|
|
groupMsgToView gInfo ci'
|
|
| otherwise = do
|
|
file_ <- processFileInv
|
|
ci <- createNonLive file_
|
|
toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt
|
|
createNonLive file_ =
|
|
saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content, ts) (snd <$> file_) timed' False mentions
|
|
createContentItem = do
|
|
file_ <- processFileInv
|
|
newChatItem (CIRcvMsgContent content, ts) (snd <$> file_) timed' live'
|
|
when (showMessages $ memberSettings m) $ autoAcceptFile file_
|
|
processFileInv =
|
|
processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m
|
|
newChatItem ciContent ciFile_ timed_ live = do
|
|
let mentions' = if showMessages (memberSettings m) then mentions else []
|
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs ciContent ciFile_ timed_ live mentions'
|
|
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 ci' {reactions}
|
|
|
|
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MemberMention -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
|
|
groupMessageUpdate gInfo@GroupInfo {groupId} m@GroupMember {groupMemberId, memberId} sharedMsgId mc mentions msg@RcvMessage {msgId} brokerTs ttl_ live_
|
|
| prohibitedSimplexLinks gInfo m ft_ =
|
|
messageWarning $ "x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
|
|
| otherwise = do
|
|
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).
|
|
-- Chat item and update message which created it will have different sharedMsgId in this case...
|
|
let timed_ = rcvGroupCITimed gInfo ttl_
|
|
mentions' = if showMessages (memberSettings m) then mentions else []
|
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions'
|
|
ci' <- withStore' $ \db -> do
|
|
createChatItemVersion db (chatItemId' ci) brokerTs mc
|
|
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
|
|
blockedMember m ci' $ markGroupChatItemBlocked db user gInfo ci'
|
|
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
|
where
|
|
content = CIRcvMsgContent mc
|
|
ts@(_, ft_) = msgContentTexts mc
|
|
live = fromMaybe False live_
|
|
updateRcvChatItem = do
|
|
cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
|
case cci of
|
|
CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} ->
|
|
if sameMemberId memberId m'
|
|
then do
|
|
let changed = mc /= oldMC
|
|
if changed || fromMaybe False itemLive
|
|
then do
|
|
ci' <- withStore' $ \db -> do
|
|
when changed $
|
|
addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (brokerTs, mc)
|
|
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
|
|
let edited = itemLive /= Just True
|
|
mentionedMembers <- getRcvMentionedMembers db user gInfo ft_ mentions
|
|
ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId
|
|
updateGroupCIMentions db gInfo ci' mentionedMembers
|
|
toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci')
|
|
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"
|
|
_ -> messageError "x.msg.update: group member attempted invalid message update"
|
|
|
|
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM ()
|
|
groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do
|
|
let msgMemberId = fromMaybe memberId sndMemberId_
|
|
withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
|
|
Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of
|
|
CIGroupRcv mem -> case sndMemberId_ of
|
|
-- regular deletion
|
|
Nothing
|
|
| sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs ->
|
|
delete cci Nothing >>= toView
|
|
| otherwise ->
|
|
messageError "x.msg.del: member attempted invalid message delete"
|
|
-- moderation (not limited by time)
|
|
Just _
|
|
| sameMemberId memberId mem && msgMemberId == memberId ->
|
|
delete cci (Just m) >>= toView
|
|
| otherwise ->
|
|
moderate mem cci
|
|
CIGroupSnd -> moderate membership cci
|
|
Left e
|
|
| msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e
|
|
| senderRole < GRModerator -> 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
|
|
moderate :: GroupMember -> CChatItem 'CTGroup -> CM ()
|
|
moderate mem cci = case sndMemberId_ of
|
|
Just sndMemberId
|
|
| sameMemberId sndMemberId mem -> checkRole mem $ do
|
|
delete cci (Just m) >>= toView
|
|
archiveMessageReports cci m
|
|
| otherwise -> messageError "x.msg.del: message of another member with incorrect memberId"
|
|
_ -> messageError "x.msg.del: message of another member without memberId"
|
|
checkRole GroupMember {memberRole} a
|
|
| senderRole < GRModerator || senderRole < memberRole =
|
|
messageError "x.msg.del: message of another member with insufficient member permissions"
|
|
| otherwise = a
|
|
delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM ChatResponse
|
|
delete cci byGroupMember
|
|
| groupFeatureMemberAllowed SGFFullDelete m gInfo = deleteGroupCIs user gInfo [cci] False False byGroupMember brokerTs
|
|
| otherwise = markGroupCIsDeleted user gInfo [cci] False byGroupMember brokerTs
|
|
archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
|
|
archiveMessageReports (CChatItem _ ci) byMember = do
|
|
ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs
|
|
unless (null ciIds) $ toView $ CRGroupChatItemsDeleted user gInfo ciIds False (Just byMember)
|
|
|
|
-- TODO remove once XFile is discontinued
|
|
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM ()
|
|
processFileInvitation' ct fInv' msg@RcvMessage {sharedMsgId_} msgMeta = do
|
|
ChatConfig {fileChunkSize} <- asks config
|
|
let fInv@FileInvitation {fileName, fileSize} = mkValidFileInvitation fInv'
|
|
inline <- receiveInlineMode fInv Nothing fileChunkSize
|
|
RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvFileTransfer db userId ct fInv inline fileChunkSize
|
|
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
|
|
ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol}
|
|
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
|
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
|
|
-- TODO remove once XFile is discontinued
|
|
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM ()
|
|
processGroupFileInvitation' gInfo m fInv@FileInvitation {fileName, fileSize} msg@RcvMessage {sharedMsgId_} brokerTs = 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}
|
|
content = ciContentNoParse $ CIRcvMsgContent $ MCFile ""
|
|
ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty
|
|
ci' <- blockedMember m ci $ withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci
|
|
groupMsgToView gInfo ci'
|
|
|
|
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 -> CM (Maybe InlineFileMode)
|
|
receiveInlineMode FileInvitation {fileSize, fileInline, fileDescr} mc_ chSize = case (fileInline, fileDescr) of
|
|
(Just mode, Nothing) -> do
|
|
InlineFilesConfig {receiveChunks, receiveInstant} <- asks $ inlineFiles . config
|
|
pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing
|
|
where
|
|
inline' receiveInstant = if mode == IFMOffer || (receiveInstant && maybe False isVoice mc_) then fileInline else Nothing
|
|
_ -> pure Nothing
|
|
|
|
xFileCancel :: Contact -> SharedMsgId -> CM ()
|
|
xFileCancel Contact {contactId} sharedMsgId = do
|
|
fileId <- withStore $ \db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
|
|
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
|
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
|
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
|
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileSndCancelled user ci ft
|
|
|
|
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
|
|
xFileAcptInv ct sharedMsgId fileConnReq_ fName = do
|
|
fileId <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
|
|
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
|
assertSMPAcceptNotProhibited ci
|
|
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
if fName == fileName
|
|
then unless cancelled $ case fileConnReq_ of
|
|
-- receiving via a separate connection
|
|
Just fileConnReq -> do
|
|
subMode <- chatReadVar subscriptionMode
|
|
dm <- encodeConnInfo XOk
|
|
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
|
|
withStore' $ \db -> createSndDirectFTConnection db vr user fileId connIds subMode
|
|
-- receiving inline
|
|
_ -> do
|
|
event <- withStore $ \db -> do
|
|
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
|
sft <- createSndDirectInlineFT db ct ft
|
|
pure $ CRSndFileStart user ci' sft
|
|
toView event
|
|
ifM
|
|
(allowSendInline fileSize fileInline)
|
|
(sendDirectFileInline user ct ft sharedMsgId)
|
|
(messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline")
|
|
else messageError "x.file.acpt.inv: fileName is different from expected"
|
|
|
|
assertSMPAcceptNotProhibited :: ChatItem c d -> CM ()
|
|
assertSMPAcceptNotProhibited ChatItem {file = Just CIFile {fileId, fileProtocol}, content}
|
|
| fileProtocol == FPXFTP && not (imageOrVoice content) = throwChatError $ CEFallbackToSMPProhibited fileId
|
|
| otherwise = pure ()
|
|
where
|
|
imageOrVoice :: CIContent d -> Bool
|
|
imageOrVoice (CISndMsgContent (MCImage _ _)) = True
|
|
imageOrVoice (CISndMsgContent (MCVoice _ _)) = True
|
|
imageOrVoice _ = False
|
|
assertSMPAcceptNotProhibited _ = pure ()
|
|
|
|
checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM ()
|
|
checkSndInlineFTComplete conn agentMsgId = do
|
|
sft_ <- withStore' $ \db -> getSndFTViaMsgDelivery db user conn agentMsgId
|
|
forM_ sft_ $ \sft@SndFileTransfer {fileId} -> do
|
|
ci@(AChatItem _ _ _ ChatItem {file}) <- withStore $ \db -> do
|
|
liftIO $ updateSndFileStatus db sft FSComplete
|
|
liftIO $ deleteSndFileChunks db sft
|
|
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
|
|
case file of
|
|
Just CIFile {fileProtocol = FPXFTP} -> do
|
|
ft <- withStore $ \db -> getFileTransferMeta db user fileId
|
|
toView $ CRSndFileCompleteXFTP user ci ft
|
|
_ -> toView $ CRSndFileComplete user ci sft
|
|
|
|
allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool
|
|
allowSendInline fileSize = \case
|
|
Just IFMOffer -> do
|
|
ChatConfig {fileChunkSize, inlineFiles} <- asks config
|
|
pure $ fileSize <= fileChunkSize * offerChunks inlineFiles
|
|
_ -> pure False
|
|
|
|
bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
|
|
bFileChunk ct sharedMsgId chunk meta = do
|
|
ft <- withStore $ \db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user
|
|
receiveInlineChunk ft chunk meta
|
|
|
|
bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
|
|
bFileChunkGroup GroupInfo {groupId} sharedMsgId chunk meta = do
|
|
ft <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user
|
|
receiveInlineChunk ft chunk meta
|
|
|
|
receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
|
|
receiveInlineChunk RcvFileTransfer {fileId, fileStatus = RFSNew} FileChunk {chunkNo} _
|
|
| chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId
|
|
| otherwise = pure ()
|
|
receiveInlineChunk ft@RcvFileTransfer {fileId} chunk meta = do
|
|
case chunk of
|
|
FileChunk {chunkNo} -> when (chunkNo == 1) $ startReceivingFile user fileId
|
|
_ -> pure ()
|
|
receiveFileChunk ft Nothing meta chunk
|
|
|
|
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM ()
|
|
xFileCancelGroup GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId = do
|
|
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
|
CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId
|
|
case (msgDir, chatDir) of
|
|
(SMDRcv, CIGroupRcv m) -> do
|
|
if sameMemberId memberId m
|
|
then do
|
|
ft <- withStore (\db -> getRcvFileTransfer db user fileId)
|
|
unless (rcvFileCompleteOrCancelled ft) $ do
|
|
cancelRcvFileTransfer user ft >>= mapM_ (deleteAgentConnectionAsync user)
|
|
ci <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
|
toView $ CRRcvFileSndCancelled user ci ft
|
|
else messageError "x.file.cancel: group member attempted to cancel file of another member" -- shouldn't happen now that query includes group member id
|
|
(SMDSnd, _) -> messageError "x.file.cancel: group member attempted invalid file cancel"
|
|
|
|
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
|
|
xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do
|
|
fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
|
|
(AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db vr user fileId
|
|
assertSMPAcceptNotProhibited ci
|
|
-- TODO check that it's not already accepted
|
|
ft@FileTransferMeta {fileName, fileSize, fileInline, cancelled} <- withStore (\db -> getFileTransferMeta db user fileId)
|
|
if fName == fileName
|
|
then unless cancelled $ case (fileConnReq_, activeConn) of
|
|
(Just fileConnReq, _) -> do
|
|
subMode <- chatReadVar subscriptionMode
|
|
-- receiving via a separate connection
|
|
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
|
|
dm <- encodeConnInfo XOk
|
|
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
|
|
withStore' $ \db -> createSndGroupFileTransferConnection db vr user fileId connIds m subMode
|
|
(_, Just conn) -> do
|
|
-- receiving inline
|
|
event <- withStore $ \db -> do
|
|
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
|
|
sft <- liftIO $ createSndGroupInlineFT db m conn ft
|
|
pure $ CRSndFileStart user ci' sft
|
|
toView event
|
|
ifM
|
|
(allowSendInline fileSize fileInline)
|
|
(sendMemberFileInline m conn ft sharedMsgId)
|
|
(messageError "x.file.acpt.inv: fileSize is bigger than allowed to send inline")
|
|
_ -> messageError "x.file.acpt.inv: member connection is not active"
|
|
else messageError "x.file.acpt.inv: fileName is different from expected"
|
|
|
|
groupMsgToView :: forall d. MsgDirectionI d => GroupInfo -> ChatItem 'CTGroup d -> CM ()
|
|
groupMsgToView gInfo ci =
|
|
toView $ CRNewChatItems user [AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci]
|
|
|
|
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM ()
|
|
processGroupInvitation ct inv msg msgMeta = do
|
|
let Contact {localDisplayName = c, activeConn} = ct
|
|
GroupInvitation {fromMember = (MemberIdRole fromMemId fromRole), invitedMember = (MemberIdRole memId memRole), connRequest, groupLinkId} = inv
|
|
forM_ activeConn $ \Connection {connId, connChatVersion, peerChatVRange, customUserProfileId, groupLinkId = groupLinkId'} -> do
|
|
when (fromRole < GRAdmin || fromRole < memRole) $ throwChatError (CEGroupContactRole c)
|
|
when (fromMemId == memId) $ throwChatError CEGroupDuplicateMemberId
|
|
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
|
|
(gInfo@GroupInfo {groupId, localDisplayName, groupProfile, membership}, hostId) <- withStore $ \db -> createGroupInvitation db vr user ct inv customUserProfileId
|
|
let GroupMember {groupMemberId, memberId = membershipMemId} = membership
|
|
if sameGroupLinkId groupLinkId groupLinkId'
|
|
then do
|
|
subMode <- chatReadVar subscriptionMode
|
|
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
|
|
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
|
|
withStore' $ \db -> do
|
|
setViaGroupLinkHash db groupId connId
|
|
createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode
|
|
updateGroupMemberStatusById db userId hostId GSMemAccepted
|
|
updateGroupMemberStatus db userId membership GSMemAccepted
|
|
toView $ CRUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct)
|
|
else do
|
|
let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole
|
|
ci <- saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs content
|
|
withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci)
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
|
toView $ CRReceivedGroupInvitation {user, groupInfo = gInfo, contact = ct, fromMemberRole = fromRole, memberRole = memRole}
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
|
|
sameGroupLinkId (Just gli) (Just gli') = gli == gli'
|
|
sameGroupLinkId _ _ = False
|
|
|
|
checkIntegrityCreateItem :: forall c. ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> CM ()
|
|
checkIntegrityCreateItem cd MsgMeta {integrity, broker = (_, brokerTs)} = case integrity of
|
|
MsgOk -> pure ()
|
|
MsgError e -> createInternalChatItem user cd (CIRcvIntegrityError e) (Just brokerTs)
|
|
|
|
xInfo :: Contact -> Profile -> CM ()
|
|
xInfo c p' = void $ processContactProfileUpdate c p' True
|
|
|
|
xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
|
|
xDirectDel c msg msgMeta =
|
|
if directOrUsed c
|
|
then do
|
|
ct' <- withStore' $ \db -> updateContactStatus db user c CSDeleted
|
|
contactConns <- withStore' $ \db -> getContactConnections db vr userId ct'
|
|
deleteAgentConnectionsAsync user $ map aConnId contactConns
|
|
forM_ contactConns $ \conn -> withStore' $ \db -> updateConnectionStatus db conn ConnDeleted
|
|
activeConn' <- forM (contactConn ct') $ \conn -> pure conn {connStatus = ConnDeleted}
|
|
let ct'' = ct' {activeConn = activeConn'} :: Contact
|
|
ci <- saveRcvChatItemNoParse user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted)
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct'') ci]
|
|
toView $ CRContactDeletedByContact user ct''
|
|
else do
|
|
contactConns <- withStore' $ \db -> getContactConnections db vr userId c
|
|
deleteAgentConnectionsAsync user $ map aConnId contactConns
|
|
withStore $ \db -> deleteContact db user c
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
|
|
processContactProfileUpdate :: Contact -> Profile -> Bool -> CM Contact
|
|
processContactProfileUpdate c@Contact {profile = lp} p' createItems
|
|
| p /= p' = do
|
|
c' <- withStore $ \db ->
|
|
if userTTL == rcvTTL
|
|
then updateContactProfile db user c p'
|
|
else do
|
|
c' <- liftIO $ updateContactUserPreferences db user c ctUserPrefs'
|
|
updateContactProfile db user c' p'
|
|
when (directOrUsed c' && createItems) $ do
|
|
createProfileUpdatedItem c'
|
|
lift $ createRcvFeatureItems user c c'
|
|
toView $ CRContactUpdated user c c'
|
|
pure c'
|
|
| otherwise =
|
|
pure c
|
|
where
|
|
p = fromLocalProfile lp
|
|
Contact {userPreferences = ctUserPrefs@Preferences {timedMessages = ctUserTMPref}} = c
|
|
userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs
|
|
Profile {preferences = rcvPrefs_} = p'
|
|
rcvTTL = prefParam $ getPreference SCFTimedMessages rcvPrefs_
|
|
ctUserPrefs' =
|
|
let userDefault = getPreference SCFTimedMessages (fullPreferences user)
|
|
userDefaultTTL = prefParam userDefault
|
|
ctUserTMPref' = case ctUserTMPref of
|
|
Just userTM -> Just (userTM :: TimedMessagesPreference) {ttl = rcvTTL}
|
|
_
|
|
| rcvTTL /= userDefaultTTL -> Just (userDefault :: TimedMessagesPreference) {ttl = rcvTTL}
|
|
| otherwise -> Nothing
|
|
in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs
|
|
createProfileUpdatedItem c' =
|
|
when visibleProfileUpdated $ do
|
|
let ciContent = CIRcvDirectEvent $ RDEProfileUpdated p p'
|
|
createInternalChatItem user (CDDirectRcv c') ciContent Nothing
|
|
where
|
|
visibleProfileUpdated =
|
|
n' /= n || fn' /= fn || i' /= i || cl' /= cl
|
|
Profile {displayName = n, fullName = fn, image = i, contactLink = cl} = p
|
|
Profile {displayName = n', fullName = fn', image = i', contactLink = cl'} = p'
|
|
|
|
xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM ()
|
|
xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True (Just brokerTs)
|
|
|
|
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
|
|
xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' = do
|
|
xGrpLinkMemReceived <- withStore $ \db -> getXGrpLinkMemReceived db groupMemberId
|
|
if (viaGroupLink || isJust businessChat) && isNothing (memberContactId m) && memberCategory == GCHostMember && not xGrpLinkMemReceived
|
|
then do
|
|
m' <- processMemberProfileUpdate gInfo m p' False Nothing
|
|
withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True
|
|
let connectedIncognito = memberIncognito membership
|
|
probeMatchingMemberContact m' connectedIncognito
|
|
else messageError "x.grp.link.mem error: invalid group link host profile update"
|
|
|
|
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember
|
|
processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' createItems itemTs_
|
|
| redactedMemberProfile (fromLocalProfile p) /= redactedMemberProfile p' = do
|
|
updateBusinessChatProfile gInfo
|
|
case memberContactId of
|
|
Nothing -> do
|
|
m' <- withStore $ \db -> updateMemberProfile db user m p'
|
|
createProfileUpdatedItem m'
|
|
toView $ CRGroupMemberUpdated user gInfo m m'
|
|
pure m'
|
|
Just mContactId -> do
|
|
mCt <- withStore $ \db -> getContact db vr user mContactId
|
|
if canUpdateProfile mCt
|
|
then do
|
|
(m', ct') <- withStore $ \db -> updateContactMemberProfile db user m mCt p'
|
|
createProfileUpdatedItem m'
|
|
toView $ CRGroupMemberUpdated user gInfo m m'
|
|
toView $ CRContactUpdated user mCt ct'
|
|
pure m'
|
|
else pure m
|
|
where
|
|
canUpdateProfile ct
|
|
| not (contactActive ct) = True
|
|
| otherwise = case contactConn ct of
|
|
Nothing -> True
|
|
Just conn -> not (connReady conn) || (authErrCounter conn >= 1)
|
|
| otherwise =
|
|
pure m
|
|
where
|
|
updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of
|
|
Just bc | isMainBusinessMember bc m -> do
|
|
g' <- withStore $ \db -> updateGroupProfileFromMember db user g p'
|
|
toView $ CRGroupUpdated user g g' (Just m)
|
|
_ -> pure ()
|
|
isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of
|
|
BCBusiness -> businessId == memberId
|
|
BCCustomer -> customerId == memberId
|
|
createProfileUpdatedItem m' =
|
|
when createItems $ do
|
|
let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p'
|
|
createInternalChatItem user (CDGroupRcv gInfo m') ciContent itemTs_
|
|
|
|
createFeatureEnabledItems :: Contact -> CM ()
|
|
createFeatureEnabledItems ct@Contact {mergedPreferences} =
|
|
forM_ allChatFeatures $ \(ACF f) -> do
|
|
let state = featureState $ getContactUserPreference f mergedPreferences
|
|
createInternalChatItem user (CDDirectRcv ct) (uncurry (CIRcvChatFeature $ chatFeature f) state) Nothing
|
|
|
|
xInfoProbe :: ContactOrMember -> Probe -> CM ()
|
|
xInfoProbe cgm2 probe = do
|
|
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
|
-- [incognito] unless connected incognito
|
|
when (contactMerge && not (contactOrMemberIncognito cgm2)) $ do
|
|
cgm1s <- withStore' $ \db -> matchReceivedProbe db vr user cgm2 probe
|
|
let cgm1s' = filter (not . contactOrMemberIncognito) cgm1s
|
|
probeMatches cgm1s' cgm2
|
|
where
|
|
probeMatches :: [ContactOrMember] -> ContactOrMember -> CM ()
|
|
probeMatches [] _ = pure ()
|
|
probeMatches (cgm1' : cgm1s') cgm2' = do
|
|
cgm2''_ <- probeMatch cgm1' cgm2' probe `catchChatError` \_ -> pure (Just cgm2')
|
|
let cgm2'' = fromMaybe cgm2' cgm2''_
|
|
probeMatches cgm1s' cgm2''
|
|
|
|
xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM ()
|
|
xInfoProbeCheck cgm1 probeHash = do
|
|
contactMerge <- readTVarIO =<< asks contactMergeEnabled
|
|
-- [incognito] unless connected incognito
|
|
when (contactMerge && not (contactOrMemberIncognito cgm1)) $ do
|
|
cgm2Probe_ <- withStore' $ \db -> matchReceivedProbeHash db vr user cgm1 probeHash
|
|
forM_ cgm2Probe_ $ \(cgm2, probe) ->
|
|
unless (contactOrMemberIncognito cgm2) . void $
|
|
probeMatch cgm1 cgm2 probe
|
|
|
|
probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> CM (Maybe ContactOrMember)
|
|
probeMatch cgm1 cgm2 probe =
|
|
case cgm1 of
|
|
COMContact c1@Contact {contactId = cId1, profile = p1} ->
|
|
case cgm2 of
|
|
COMContact c2@Contact {contactId = cId2, profile = p2}
|
|
| cId1 /= cId2 && profilesMatch p1 p2 -> do
|
|
void . sendDirectContactMessage user c1 $ XInfoProbeOk probe
|
|
COMContact <$$> mergeContacts c1 c2
|
|
| otherwise -> messageWarning "probeMatch ignored: profiles don't match or same contact id" >> pure Nothing
|
|
COMGroupMember m2@GroupMember {memberProfile = p2, memberContactId}
|
|
| isNothing memberContactId && profilesMatch p1 p2 -> do
|
|
void . sendDirectContactMessage user c1 $ XInfoProbeOk probe
|
|
COMContact <$$> associateMemberAndContact c1 m2
|
|
| otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact" >> pure Nothing
|
|
COMGroupMember GroupMember {activeConn = Nothing} -> pure Nothing
|
|
COMGroupMember m1@GroupMember {groupId, memberProfile = p1, memberContactId, activeConn = Just conn} ->
|
|
case cgm2 of
|
|
COMContact c2@Contact {profile = p2}
|
|
| memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> do
|
|
void $ sendDirectMemberMessage conn (XInfoProbeOk probe) groupId
|
|
COMContact <$$> associateMemberAndContact c2 m1
|
|
| otherwise -> messageWarning "probeMatch ignored: profiles don't match or member already has contact or member not current" >> pure Nothing
|
|
COMGroupMember _ -> messageWarning "probeMatch ignored: members are not matched with members" >> pure Nothing
|
|
|
|
xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
|
|
xInfoProbeOk cgm1 probe = do
|
|
cgm2 <- withStore' $ \db -> matchSentProbe db vr user cgm1 probe
|
|
case cgm1 of
|
|
COMContact c1@Contact {contactId = cId1} ->
|
|
case cgm2 of
|
|
Just (COMContact c2@Contact {contactId = cId2})
|
|
| cId1 /= cId2 -> void $ mergeContacts c1 c2
|
|
| otherwise -> messageWarning "xInfoProbeOk ignored: same contact id"
|
|
Just (COMGroupMember m2@GroupMember {memberContactId})
|
|
| isNothing memberContactId -> void $ associateMemberAndContact c1 m2
|
|
| otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact"
|
|
_ -> pure ()
|
|
COMGroupMember m1@GroupMember {memberContactId} ->
|
|
case cgm2 of
|
|
Just (COMContact c2)
|
|
| isNothing memberContactId -> void $ associateMemberAndContact c2 m1
|
|
| otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact"
|
|
Just (COMGroupMember _) -> messageWarning "xInfoProbeOk ignored: members are not matched with members"
|
|
_ -> pure ()
|
|
|
|
-- to party accepting call
|
|
xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM ()
|
|
xCallInv ct@Contact {contactId} callId CallInvitation {callType, callDhPubKey} msg@RcvMessage {sharedMsgId_} msgMeta = do
|
|
if featureAllowed SCFCalls forContact ct
|
|
then do
|
|
g <- asks random
|
|
dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C.generateKeyPair g else pure Nothing
|
|
ci <- saveCallItem CISCallPending
|
|
callUUID <- UUID.toText <$> liftIO V4.nextRandom
|
|
let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> (snd <$> dhKeyPair))
|
|
callState = CallInvitationReceived {peerCallType = callType, localDhPubKey = fst <$> dhKeyPair, sharedKey}
|
|
call' = Call {contactId, callId, callUUID, chatItemId = chatItemId' ci, callState, callTs = chatItemTs' ci}
|
|
calls <- asks currentCalls
|
|
-- theoretically, the new call invitation for the current contact can mark the in-progress call as ended
|
|
-- (and replace it in ChatController)
|
|
-- practically, this should not happen
|
|
withStore' $ \db -> createCall db user call' $ chatItemTs' ci
|
|
call_ <- atomically (TM.lookupInsert contactId call' calls)
|
|
forM_ call_ $ \call -> updateCallItemStatus user ct call WCSDisconnected Nothing
|
|
toView $ CRCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callUUID, callTs = chatItemTs' ci}
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
|
else featureRejected CFCalls
|
|
where
|
|
brokerTs = metaBrokerTs msgMeta
|
|
saveCallItem status = saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs (CIRcvCall status 0)
|
|
featureRejected f = do
|
|
let content = ciContentNoParse $ CIRcvChatFeatureRejected f
|
|
ci <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat ct) ci]
|
|
|
|
-- to party initiating call
|
|
xCallOffer :: Contact -> CallId -> CallOffer -> RcvMessage -> CM ()
|
|
xCallOffer ct callId CallOffer {callType, rtcSession, callDhPubKey} msg = do
|
|
msgCurrentCall ct callId "x.call.offer" msg $
|
|
\call -> case callState call of
|
|
CallInvitationSent {localCallType, localDhPrivKey} -> do
|
|
let sharedKey = C.Key . C.dhBytes' <$> (C.dh' <$> callDhPubKey <*> localDhPrivKey)
|
|
callState' = CallOfferReceived {localCallType, peerCallType = callType, peerCallSession = rtcSession, sharedKey}
|
|
askConfirmation = encryptedCall localCallType && not (encryptedCall callType)
|
|
toView CRCallOffer {user, contact = ct, callType, offer = rtcSession, sharedKey, askConfirmation}
|
|
pure (Just call {callState = callState'}, Just . ACIContent SMDSnd $ CISndCall CISCallAccepted 0)
|
|
_ -> do
|
|
msgCallStateError "x.call.offer" call
|
|
pure (Just call, Nothing)
|
|
|
|
-- to party accepting call
|
|
xCallAnswer :: Contact -> CallId -> CallAnswer -> RcvMessage -> CM ()
|
|
xCallAnswer ct callId CallAnswer {rtcSession} msg = do
|
|
msgCurrentCall ct callId "x.call.answer" msg $
|
|
\call -> case callState call of
|
|
CallOfferSent {localCallType, peerCallType, localCallSession, sharedKey} -> do
|
|
let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession = rtcSession, sharedKey}
|
|
toView $ CRCallAnswer user ct rtcSession
|
|
pure (Just call {callState = callState'}, Just . ACIContent SMDRcv $ CIRcvCall CISCallNegotiated 0)
|
|
_ -> do
|
|
msgCallStateError "x.call.answer" call
|
|
pure (Just call, Nothing)
|
|
|
|
-- to any call party
|
|
xCallExtra :: Contact -> CallId -> CallExtraInfo -> RcvMessage -> CM ()
|
|
xCallExtra ct callId CallExtraInfo {rtcExtraInfo} msg = do
|
|
msgCurrentCall ct callId "x.call.extra" msg $
|
|
\call -> case callState call of
|
|
CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey} -> do
|
|
-- TODO update the list of ice servers in peerCallSession
|
|
let callState' = CallOfferReceived {localCallType, peerCallType, peerCallSession, sharedKey}
|
|
toView $ CRCallExtraInfo user ct rtcExtraInfo
|
|
pure (Just call {callState = callState'}, Nothing)
|
|
CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey} -> do
|
|
-- TODO update the list of ice servers in peerCallSession
|
|
let callState' = CallNegotiated {localCallType, peerCallType, localCallSession, peerCallSession, sharedKey}
|
|
toView $ CRCallExtraInfo user ct rtcExtraInfo
|
|
pure (Just call {callState = callState'}, Nothing)
|
|
_ -> do
|
|
msgCallStateError "x.call.extra" call
|
|
pure (Just call, Nothing)
|
|
|
|
-- to any call party
|
|
xCallEnd :: Contact -> CallId -> RcvMessage -> CM ()
|
|
xCallEnd ct callId msg =
|
|
msgCurrentCall ct callId "x.call.end" msg $ \Call {chatItemId} -> do
|
|
toView $ CRCallEnded user ct
|
|
(Nothing,) <$> callStatusItemContent user ct chatItemId WCSDisconnected
|
|
|
|
msgCurrentCall :: Contact -> CallId -> Text -> RcvMessage -> (Call -> CM (Maybe Call, Maybe ACIContent)) -> CM ()
|
|
msgCurrentCall ct@Contact {contactId = ctId'} callId' eventName RcvMessage {msgId} action = do
|
|
calls <- asks currentCalls
|
|
atomically (TM.lookup ctId' calls) >>= \case
|
|
Nothing -> messageError $ eventName <> ": no current call"
|
|
Just call@Call {contactId, callId, chatItemId}
|
|
| contactId /= ctId' || callId /= callId' -> messageError $ eventName <> ": wrong contact or callId"
|
|
| otherwise -> do
|
|
(call_, aciContent_) <- action call
|
|
case call_ of
|
|
Just call' -> do
|
|
unless (isRcvInvitation call') $ withStore' $ \db -> deleteCalls db user ctId'
|
|
atomically $ TM.insert ctId' call' calls
|
|
_ -> do
|
|
withStore' $ \db -> deleteCalls db user ctId'
|
|
atomically $ TM.delete ctId' calls
|
|
forM_ aciContent_ $ \aciContent -> do
|
|
timed_ <- callTimed ct aciContent
|
|
updateDirectChatItemView user ct chatItemId aciContent False False timed_ $ Just msgId
|
|
forM_ (timed_ >>= timedDeleteAt') $
|
|
startProximateTimedItemThread user (ChatRef CTDirect ctId', chatItemId)
|
|
|
|
msgCallStateError :: Text -> Call -> CM ()
|
|
msgCallStateError eventName Call {callState} =
|
|
messageError $ eventName <> ": wrong call state " <> T.pack (show $ callStateTag callState)
|
|
|
|
mergeContacts :: Contact -> Contact -> CM (Maybe Contact)
|
|
mergeContacts c1 c2 = do
|
|
let Contact {localDisplayName = cLDN1, profile = LocalProfile {displayName}} = c1
|
|
Contact {localDisplayName = cLDN2} = c2
|
|
case (suffixOrd displayName cLDN1, suffixOrd displayName cLDN2) of
|
|
(Just cOrd1, Just cOrd2)
|
|
| cOrd1 < cOrd2 -> merge c1 c2
|
|
| cOrd2 < cOrd1 -> merge c2 c1
|
|
| otherwise -> pure Nothing
|
|
_ -> pure Nothing
|
|
where
|
|
merge c1' c2' = do
|
|
c2'' <- withStore $ \db -> mergeContactRecords db vr user c1' c2'
|
|
toView $ CRContactsMerged user c1' c2' c2''
|
|
when (directOrUsed c2'') $ showSecurityCodeChanged c2''
|
|
pure $ Just c2''
|
|
where
|
|
showSecurityCodeChanged mergedCt = do
|
|
let sc1_ = contactSecurityCode c1'
|
|
sc2_ = contactSecurityCode c2'
|
|
scMerged_ = contactSecurityCode mergedCt
|
|
case (sc1_, sc2_) of
|
|
(Just sc1, Nothing)
|
|
| scMerged_ /= Just sc1 -> securityCodeChanged mergedCt
|
|
| otherwise -> pure ()
|
|
(Nothing, Just sc2)
|
|
| scMerged_ /= Just sc2 -> securityCodeChanged mergedCt
|
|
| otherwise -> pure ()
|
|
_ -> pure ()
|
|
|
|
associateMemberAndContact :: Contact -> GroupMember -> CM (Maybe Contact)
|
|
associateMemberAndContact c m = do
|
|
let Contact {localDisplayName = cLDN, profile = LocalProfile {displayName}} = c
|
|
GroupMember {localDisplayName = mLDN} = m
|
|
case (suffixOrd displayName cLDN, suffixOrd displayName mLDN) of
|
|
(Just cOrd, Just mOrd)
|
|
| cOrd < mOrd -> Just <$> associateMemberWithContact c m
|
|
| mOrd < cOrd -> Just <$> associateContactWithMember m c
|
|
| otherwise -> pure Nothing
|
|
_ -> pure Nothing
|
|
|
|
suffixOrd :: ContactName -> ContactName -> Maybe Int
|
|
suffixOrd displayName localDisplayName
|
|
| localDisplayName == displayName = Just 0
|
|
| otherwise = case T.stripPrefix (displayName <> "_") localDisplayName of
|
|
Just suffix -> readMaybe $ T.unpack suffix
|
|
Nothing -> Nothing
|
|
|
|
associateMemberWithContact :: Contact -> GroupMember -> CM Contact
|
|
associateMemberWithContact c1 m2@GroupMember {groupId} = do
|
|
withStore' $ \db -> associateMemberWithContactRecord db user c1 m2
|
|
g <- withStore $ \db -> getGroupInfo db vr user groupId
|
|
toView $ CRContactAndMemberAssociated user c1 g m2 c1
|
|
pure c1
|
|
|
|
associateContactWithMember :: GroupMember -> Contact -> CM Contact
|
|
associateContactWithMember m1@GroupMember {groupId} c2 = do
|
|
c2' <- withStore $ \db -> associateContactWithMemberRecord db vr user m1 c2
|
|
g <- withStore $ \db -> getGroupInfo db vr user groupId
|
|
toView $ CRContactAndMemberAssociated user c2 g m1 c2'
|
|
pure c2'
|
|
|
|
saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Bool)
|
|
saveConnInfo activeConn connInfo = do
|
|
ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo
|
|
conn' <- updatePeerChatVRange activeConn chatVRange
|
|
case chatMsgEvent of
|
|
XInfo p -> do
|
|
let contactUsed = connDirect activeConn
|
|
ct <- withStore $ \db -> createDirectContact db user conn' p contactUsed
|
|
toView $ CRContactConnecting user ct
|
|
pure (conn', False)
|
|
XGrpLinkInv glInv -> do
|
|
(gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv
|
|
toView $ CRGroupLinkConnecting user gInfo host
|
|
pure (conn', True)
|
|
-- TODO show/log error, other events in SMP confirmation
|
|
_ -> pure (conn', False)
|
|
|
|
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _) msg brokerTs = do
|
|
checkHostRole m memRole
|
|
unless (sameMemberId memId $ membership gInfo) $
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do
|
|
updatedMember <- withStore $ \db -> updateUnknownMemberAnnounced db vr user m unknownMember memInfo
|
|
toView $ CRUnknownMemberAnnounced user gInfo m unknownMember updatedMember
|
|
memberAnnouncedToView updatedMember
|
|
Right _ -> messageError "x.grp.mem.new error: member already exists"
|
|
Left _ -> do
|
|
newMember <- withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
|
|
memberAnnouncedToView newMember
|
|
where
|
|
memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} = do
|
|
let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile)
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent event)
|
|
groupMsgToView gInfo ci
|
|
toView $ CRJoinedGroupMemberConnecting user gInfo m announcedMember
|
|
|
|
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
|
|
xGrpMemIntro gInfo@GroupInfo {chatSettings} m@GroupMember {memberRole, localDisplayName = c} memInfo@(MemberInfo memId _ memChatVRange _) memRestrictions = do
|
|
case memberCategory m of
|
|
GCHostMember ->
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Right _ -> messageError "x.grp.mem.intro ignored: member already exists"
|
|
Left _ -> do
|
|
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c)
|
|
subMode <- chatReadVar subscriptionMode
|
|
-- [async agent commands] commands should be asynchronous, continuation is to send XGrpMemInv - have to remember one has completed and process on second
|
|
groupConnIds <- createConn subMode
|
|
directConnIds <- case memChatVRange of
|
|
Nothing -> Just <$> createConn subMode
|
|
Just (ChatVersionRange mcvr)
|
|
| maxVersion mcvr >= groupDirectInvVersion -> pure Nothing
|
|
| otherwise -> Just <$> createConn subMode
|
|
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
|
|
chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange
|
|
void $ withStore $ \db -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds directConnIds customUserProfileId subMode
|
|
_ -> messageError "x.grp.mem.intro can be only sent by host member"
|
|
where
|
|
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv (chatHasNtfs chatSettings) SCMInvitation subMode
|
|
|
|
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
|
|
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont {groupId, groupMemberId, memberId, groupConnReq} = do
|
|
hostConn <- withStore $ \db -> getConnectionById db vr user hostConnId
|
|
let msg = XGrpMemInv memberId IntroInvitation {groupConnReq, directConnReq}
|
|
void $ sendDirectMemberMessage hostConn msg groupId
|
|
withStore' $ \db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited
|
|
|
|
xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM ()
|
|
xGrpMemInv gInfo m memId introInv = do
|
|
case memberCategory m of
|
|
GCInviteeMember ->
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Left _ -> messageError "x.grp.mem.inv error: referenced member does not exist"
|
|
Right reMember -> do
|
|
GroupMemberIntro {introId} <- withStore $ \db -> saveIntroInvitation db reMember m introInv
|
|
sendGroupMemberMessage user gInfo reMember (XGrpMemFwd (memberInfo m) introInv) (Just introId) $
|
|
withStore' $
|
|
\db -> updateIntroStatus db introId GMIntroInvForwarded
|
|
_ -> messageError "x.grp.mem.inv can be only sent by invitee member"
|
|
|
|
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
|
|
xGrpMemFwd gInfo@GroupInfo {membership, chatSettings} m memInfo@(MemberInfo memId memRole memChatVRange _) introInv@IntroInvitation {groupConnReq, directConnReq} = do
|
|
let GroupMember {memberId = membershipMemId} = membership
|
|
checkHostRole m memRole
|
|
toMember <-
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
|
|
-- the situation when member does not exist is an error
|
|
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
|
|
-- For now, this branch compensates for the lack of delayed message delivery.
|
|
Left _ -> withStore $ \db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
|
|
Right m' -> pure m'
|
|
withStore' $ \db -> saveMemberInvitation db toMember introInv
|
|
subMode <- chatReadVar subscriptionMode
|
|
-- [incognito] send membership incognito profile, create direct connection as incognito
|
|
let membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership
|
|
dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile
|
|
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
|
|
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 memChatVRange
|
|
chatV = vr `peerConnChatVersion` mcvr
|
|
withStore' $ \db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
|
|
|
|
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs
|
|
| membershipMemId == memId =
|
|
let gInfo' = gInfo {membership = membership {memberRole = memRole}}
|
|
in changeMemberRole gInfo' membership $ RGEUserRole memRole
|
|
| otherwise =
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
|
|
Left _ -> messageError "x.grp.mem.role with unknown member ID"
|
|
where
|
|
GroupMember {memberId = membershipMemId} = membership
|
|
changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent
|
|
| senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
|
|
| otherwise = do
|
|
withStore' $ \db -> updateGroupMemberRole db user member memRole
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
|
|
groupMsgToView gInfo ci
|
|
toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
|
|
|
|
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
|
|
checkHostRole GroupMember {memberRole, localDisplayName} memRole =
|
|
when (memberRole < GRAdmin || memberRole < memRole) $ throwChatError (CEGroupContactRole localDisplayName)
|
|
|
|
xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpMemRestrict
|
|
gInfo@GroupInfo {groupId, membership = GroupMember {memberId = membershipMemId}}
|
|
m@GroupMember {memberRole = senderRole}
|
|
memId
|
|
MemberRestrictions {restriction}
|
|
msg
|
|
brokerTs
|
|
| membershipMemId == memId =
|
|
-- member shouldn't receive this message about themselves
|
|
messageError "x.grp.mem.restrict: admin blocks you"
|
|
| otherwise =
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Right bm@GroupMember {groupMemberId = bmId, memberRole, memberProfile = bmp}
|
|
| senderRole < GRModerator || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions"
|
|
| otherwise -> do
|
|
bm' <- setMemberBlocked bmId
|
|
toggleNtf user bm' (not blocked)
|
|
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs ciContent
|
|
groupMsgToView gInfo ci
|
|
toView CRMemberBlockedForAll {user, groupInfo = gInfo, byMember = m, member = bm, blocked}
|
|
Left (SEGroupMemberNotFoundByMemberId _) -> do
|
|
bm <- createUnknownMember gInfo memId
|
|
bm' <- setMemberBlocked $ groupMemberId' bm
|
|
toView $ CRUnknownMemberBlocked user gInfo m bm'
|
|
Left e -> throwError $ ChatErrorStore e
|
|
where
|
|
setMemberBlocked bmId =
|
|
withStore $ \db -> do
|
|
liftIO $ updateGroupMemberBlocked db user groupId bmId restriction
|
|
getGroupMember db vr user groupId bmId
|
|
blocked = mrsBlocked restriction
|
|
|
|
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
|
|
xGrpMemCon gInfo sendingMember memId = do
|
|
refMember <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId
|
|
case (memberCategory sendingMember, memberCategory refMember) of
|
|
(GCInviteeMember, GCInviteeMember) ->
|
|
withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case
|
|
Right intro -> inviteeXGrpMemCon intro
|
|
Left _ ->
|
|
withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case
|
|
Right intro -> forwardMemberXGrpMemCon intro
|
|
Left _ -> messageWarning "x.grp.mem.con: no introduction"
|
|
(GCInviteeMember, _) ->
|
|
withStore' (\db -> runExceptT $ getIntroduction db refMember sendingMember) >>= \case
|
|
Right intro -> inviteeXGrpMemCon intro
|
|
Left _ -> messageWarning "x.grp.mem.con: no introduction"
|
|
(_, GCInviteeMember) ->
|
|
withStore' (\db -> runExceptT $ getIntroduction db sendingMember refMember) >>= \case
|
|
Right intro -> forwardMemberXGrpMemCon intro
|
|
Left _ -> messageWarning "x.grp.mem.con: no introductiosupportn"
|
|
-- Note: we can allow XGrpMemCon to all member categories if we decide to support broader group forwarding,
|
|
-- deduplication (see saveGroupRcvMsg, saveGroupFwdRcvMsg) already supports sending XGrpMemCon
|
|
-- to any forwarding member, not only host/inviting member;
|
|
-- database would track all members connections then
|
|
-- (currently it's done via group_member_intros for introduced connections only)
|
|
_ ->
|
|
messageWarning "x.grp.mem.con: neither member is invitee"
|
|
where
|
|
inviteeXGrpMemCon :: GroupMemberIntro -> CM ()
|
|
inviteeXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
|
|
GMIntroReConnected -> updateStatus introId GMIntroConnected
|
|
GMIntroToConnected -> pure ()
|
|
GMIntroConnected -> pure ()
|
|
_ -> updateStatus introId GMIntroToConnected
|
|
forwardMemberXGrpMemCon :: GroupMemberIntro -> CM ()
|
|
forwardMemberXGrpMemCon GroupMemberIntro {introId, introStatus} = case introStatus of
|
|
GMIntroToConnected -> updateStatus introId GMIntroConnected
|
|
GMIntroReConnected -> pure ()
|
|
GMIntroConnected -> pure ()
|
|
_ -> updateStatus introId GMIntroReConnected
|
|
updateStatus introId status = withStore' $ \db -> updateIntroStatus db introId status
|
|
|
|
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId msg brokerTs = do
|
|
let GroupMember {memberId = membershipMemId} = membership
|
|
if membershipMemId == memId
|
|
then checkRole membership $ do
|
|
deleteGroupLinkIfExists user gInfo
|
|
-- member records are not deleted to keep history
|
|
members <- withStore' $ \db -> getGroupMembers db vr user gInfo
|
|
deleteMembersConnections user members
|
|
withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved
|
|
deleteMemberItem RGEUserDeleted
|
|
toView $ CRDeletedMemberUser user gInfo {membership = membership {memberStatus = GSMemRemoved}} m
|
|
else
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
|
|
Left _ -> messageError "x.grp.mem.del with unknown member ID"
|
|
Right member@GroupMember {groupMemberId, memberProfile} ->
|
|
checkRole member $ do
|
|
-- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
|
|
deleteMemberConnection user member
|
|
-- undeleted "member connected" chat item will prevent deletion of member record
|
|
deleteOrUpdateMemberRecord user member
|
|
deleteMemberItem $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile)
|
|
toView $ CRDeletedMember user gInfo m member {memberStatus = GSMemRemoved}
|
|
where
|
|
checkRole GroupMember {memberRole} a
|
|
| senderRole < GRAdmin || senderRole < memberRole =
|
|
messageError "x.grp.mem.del with insufficient member permissions"
|
|
| otherwise = a
|
|
deleteMemberItem gEvent = do
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
|
|
groupMsgToView gInfo ci
|
|
|
|
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpLeave gInfo m msg brokerTs = do
|
|
deleteMemberConnection user m
|
|
-- member record is not deleted to allow creation of "member left" chat item
|
|
withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEMemberLeft)
|
|
groupMsgToView gInfo ci
|
|
toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft}
|
|
|
|
xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg brokerTs = do
|
|
when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner
|
|
ms <- withStore' $ \db -> do
|
|
members <- getGroupMembers db vr user gInfo
|
|
updateGroupMemberStatus db userId membership GSMemGroupDeleted
|
|
pure members
|
|
-- member records are not deleted to keep history
|
|
deleteMembersConnections user ms
|
|
ci <- saveRcvChatItemNoParse user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent RGEGroupDeleted)
|
|
groupMsgToView gInfo ci
|
|
toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
|
|
|
|
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpInfo g@GroupInfo {groupProfile = p, businessChat} m@GroupMember {memberRole} p' msg brokerTs
|
|
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions"
|
|
| otherwise = case businessChat of
|
|
Nothing -> unless (p == p') $ do
|
|
g' <- withStore $ \db -> updateGroupProfile db user g p'
|
|
toView $ CRGroupUpdated user g g' (Just m)
|
|
let cd = CDGroupRcv g' m
|
|
unless (sameGroupProfileInfo p p') $ do
|
|
ci <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p')
|
|
groupMsgToView g' ci
|
|
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'
|
|
Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
|
|
|
|
xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
|
|
xGrpPrefs g m@GroupMember {memberRole} ps'
|
|
| memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions"
|
|
| otherwise = updateGroupPrefs_ g m ps'
|
|
|
|
updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
|
|
updateGroupPrefs_ g@GroupInfo {groupProfile = p} m ps' =
|
|
unless (groupPreferences p == Just ps') $ do
|
|
g' <- withStore' $ \db -> updateGroupPreferences db user g ps'
|
|
toView $ CRGroupUpdated user g g' (Just m)
|
|
let cd = CDGroupRcv g' m
|
|
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'
|
|
|
|
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
|
|
xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do
|
|
unless (groupFeatureMemberAllowed SGFDirectMessages m g) $ messageError "x.grp.direct.inv: direct messages not allowed"
|
|
let GroupMember {memberContactId} = m
|
|
subMode <- chatReadVar subscriptionMode
|
|
case memberContactId of
|
|
Nothing -> createNewContact subMode
|
|
Just mContactId -> do
|
|
mCt <- withStore $ \db -> getContact db vr user mContactId
|
|
let Contact {activeConn, contactGrpInvSent} = mCt
|
|
forM_ activeConn $ \Connection {connId} ->
|
|
if contactGrpInvSent
|
|
then do
|
|
ownConnReq <- withStore $ \db -> getConnReqInv db connId
|
|
-- in case both members sent x.grp.direct.inv before receiving other's for processing,
|
|
-- only the one who received greater connReq joins, the other creates items and waits for confirmation
|
|
if strEncode connReq > strEncode ownConnReq
|
|
then joinExistingContact subMode mCt
|
|
else createItems mCt m
|
|
else joinExistingContact subMode mCt
|
|
where
|
|
joinExistingContact subMode mCt = do
|
|
connIds <- joinConn subMode
|
|
mCt' <- withStore $ \db -> updateMemberContactInvited db user connIds g mConn mCt subMode
|
|
createItems mCt' m
|
|
securityCodeChanged mCt'
|
|
createNewContact subMode = do
|
|
connIds <- joinConn subMode
|
|
-- [incognito] reuse membership incognito profile
|
|
(mCt', m') <- withStore' $ \db -> createMemberContactInvited db user connIds g m mConn subMode
|
|
createItems mCt' m'
|
|
joinConn subMode = do
|
|
-- [incognito] send membership incognito profile
|
|
let p = userProfileToSend user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing False
|
|
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
|
|
dm <- encodeConnInfo $ XInfo p
|
|
joinAgentConnectionAsync user True connReq dm subMode
|
|
createItems mCt' m' = do
|
|
createInternalChatItem user (CDGroupRcv g m') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing
|
|
toView $ CRNewMemberContactReceivedInv user mCt' g m'
|
|
forM_ mContent_ $ \mc -> do
|
|
ci <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc)
|
|
toView $ CRNewChatItems user [AChatItem SCTDirect SMDRcv (DirectChat mCt') ci]
|
|
|
|
securityCodeChanged :: Contact -> CM ()
|
|
securityCodeChanged ct = do
|
|
toView $ CRContactVerificationReset user ct
|
|
createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing
|
|
|
|
xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> CM ()
|
|
xGrpMsgForward gInfo@GroupInfo {groupId} m@GroupMember {memberRole, localDisplayName} memberId msg msgTs = do
|
|
when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole localDisplayName)
|
|
withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case
|
|
Right author -> processForwardedMsg author msg
|
|
Left (SEGroupMemberNotFoundByMemberId _) -> do
|
|
unknownAuthor <- createUnknownMember gInfo memberId
|
|
toView $ CRUnknownMemberCreated user gInfo m unknownAuthor
|
|
processForwardedMsg unknownAuthor msg
|
|
Left e -> throwError $ ChatErrorStore e
|
|
where
|
|
-- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated
|
|
processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM ()
|
|
processForwardedMsg author chatMsg = do
|
|
let body = LB.toStrict $ J.encode msg
|
|
rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} <- saveGroupFwdRcvMsg user groupId m author body chatMsg
|
|
case event of
|
|
XMsgNew mc -> memberCanSend author $ newGroupContentMessage gInfo author mc rcvMsg msgTs True
|
|
XMsgFileDescr sharedMsgId fileDescr -> memberCanSend author $ groupMessageFileDescription gInfo author sharedMsgId fileDescr
|
|
XMsgUpdate sharedMsgId mContent mentions ttl live -> memberCanSend author $ groupMessageUpdate gInfo author sharedMsgId mContent mentions rcvMsg msgTs ttl live
|
|
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
|
|
XMsgReact sharedMsgId (Just memId) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
|
|
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId
|
|
XInfo p -> xInfoMember gInfo author p msgTs
|
|
XGrpMemNew memInfo -> xGrpMemNew gInfo author memInfo rcvMsg msgTs
|
|
XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs
|
|
XGrpMemDel memId -> xGrpMemDel gInfo author memId rcvMsg msgTs
|
|
XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs
|
|
XGrpDel -> xGrpDel gInfo author rcvMsg msgTs
|
|
XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs
|
|
XGrpPrefs ps' -> xGrpPrefs gInfo author ps'
|
|
_ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event)
|
|
|
|
createUnknownMember :: GroupInfo -> MemberId -> CM GroupMember
|
|
createUnknownMember gInfo memberId = do
|
|
let name = T.take 7 . safeDecodeUtf8 . B64.encode . unMemberId $ memberId
|
|
withStore $ \db -> createNewUnknownGroupMember db vr user gInfo memberId name
|
|
|
|
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
|
|
directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do
|
|
checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchChatError` \_ -> pure ()
|
|
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
|
|
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
|
|
updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
|
|
|
|
groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
|
|
groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do
|
|
checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta `catchChatError` \_ -> pure ()
|
|
forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do
|
|
withStore' $ \db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
|
|
updateGroupItemsStatus gInfo m conn agentMsgId (GSSRcvd msgRcptStatus) Nothing
|
|
|
|
-- Searches chat items for many agent message IDs and updates their status
|
|
updateDirectItemsStatusMsgs :: Contact -> Connection -> [AgentMsgId] -> CIStatus 'MDSnd -> CM ()
|
|
updateDirectItemsStatusMsgs ct conn msgIds newStatus = do
|
|
cis <- withStore' $ \db -> forM msgIds $ \msgId -> runExceptT $ updateDirectItemsStatus' db ct conn msgId newStatus
|
|
let acis = map ctItem $ concat $ rights cis
|
|
unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis
|
|
where
|
|
ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct)
|
|
|
|
updateDirectItemStatus :: Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> CM ()
|
|
updateDirectItemStatus ct conn msgId newStatus = do
|
|
cis <- withStore $ \db -> updateDirectItemsStatus' db ct conn msgId newStatus
|
|
let acis = map ctItem cis
|
|
unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis
|
|
where
|
|
ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct)
|
|
|
|
updateDirectItemsStatus' :: DB.Connection -> Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> ExceptT StoreError IO [ChatItem 'CTDirect 'MDSnd]
|
|
updateDirectItemsStatus' db ct@Contact {contactId} Connection {connId} msgId newStatus = do
|
|
items <- liftIO $ getDirectChatItemsByAgentMsgId db user contactId connId msgId
|
|
catMaybes <$> mapM updateItem items
|
|
where
|
|
updateItem :: CChatItem 'CTDirect -> ExceptT StoreError IO (Maybe (ChatItem 'CTDirect 'MDSnd))
|
|
updateItem = \case
|
|
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ _}}) -> pure Nothing
|
|
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}})
|
|
| itemStatus == newStatus -> pure Nothing
|
|
| otherwise -> Just <$> updateDirectChatItemStatus db user ct itemId newStatus
|
|
_ -> pure Nothing
|
|
|
|
updateGroupMemSndStatus' :: DB.Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool
|
|
updateGroupMemSndStatus' db itemId groupMemberId newStatus =
|
|
runExceptT (getGroupSndStatus db itemId groupMemberId) >>= \case
|
|
Right (GSSRcvd _) -> pure False
|
|
Right memStatus
|
|
| memStatus == newStatus -> pure False
|
|
| otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True
|
|
_ -> pure False
|
|
|
|
updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM ()
|
|
updateGroupItemsStatus gInfo@GroupInfo {groupId} GroupMember {groupMemberId} Connection {connId} msgId newMemStatus viaProxy_ = do
|
|
items <- withStore' (\db -> getGroupChatItemsByAgentMsgId db user groupId connId msgId)
|
|
cis <- catMaybes <$> withStore (\db -> mapM (updateItem db) items)
|
|
let acis = map gItem cis
|
|
unless (null acis) $ toView $ CRChatItemsStatusesUpdated user acis
|
|
where
|
|
gItem = AChatItem SCTGroup SMDSnd (GroupChat gInfo)
|
|
updateItem :: DB.Connection -> CChatItem 'CTGroup -> ExceptT StoreError IO (Maybe (ChatItem 'CTGroup 'MDSnd))
|
|
updateItem db = \case
|
|
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemStatus = CISSndRcvd _ SSPComplete}}) -> pure Nothing
|
|
(CChatItem SMDSnd ChatItem {meta = CIMeta {itemId, itemStatus}}) -> do
|
|
forM_ viaProxy_ $ \viaProxy -> liftIO $ setGroupSndViaProxy db itemId groupMemberId viaProxy
|
|
memStatusChanged <- liftIO $ updateGroupMemSndStatus' db itemId groupMemberId newMemStatus
|
|
if memStatusChanged
|
|
then do
|
|
memStatusCounts <- liftIO $ getGroupSndStatusCounts db itemId
|
|
let newStatus = membersGroupItemStatus memStatusCounts
|
|
if newStatus /= itemStatus
|
|
then Just <$> updateGroupChatItemStatus db user gInfo itemId newStatus
|
|
else pure Nothing
|
|
else pure Nothing
|
|
_ -> pure Nothing
|