{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# 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 Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Either (lefts, partitionEithers, rights) import Data.Foldable (foldr', foldrM) import Data.Functor (($>)) import Data.Int (Int64) import Data.List (find) 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.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.Delivery import Simplex.Chat.Library.Internal import Simplex.Chat.Messages import Simplex.Chat.Messages.Batch (batchDeliveryTasks1, encodeBinaryBatch, encodeFwdElement) 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.ContactRequest import Simplex.Chat.Store.Delivery 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.RelayRequests import Simplex.Chat.Store.Shared import Simplex.Chat.Operators import Simplex.Chat.Types import Simplex.Chat.Types.MemberRelations import Simplex.Chat.Types.Preferences import Simplex.Chat.Types.Shared 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 import Simplex.Messaging.Agent.Client (getAgentWorker, temporaryOrHostError, waitForUserNetwork, waitForWork, waitWhileSuspended, withWorkItems, withWork_) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..), Worker (..)) import Simplex.Messaging.Agent.Protocol import qualified Simplex.Messaging.Agent.Protocol as AP (AgentErrorType (..)) import Simplex.Messaging.Agent.RetryInterval (withRetryInterval) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Client (NetworkRequestMode (..), 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 (smpEncode) import Simplex.Messaging.Encoding.String import Simplex.Messaging.Protocol (ErrorType (..), MsgFlags (..)) import qualified Simplex.Messaging.Protocol as SMP import Simplex.Messaging.ServiceScheme (ServiceScheme (..)) 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.Concurrent (forkIO) import UnliftIO.Directory import UnliftIO.STM smallGroupsRcptsMemLimit :: Int smallGroupsRcptsMemLimit = 20 processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM () processAgentMessage _ _ (DEL_RCVQS delQs) = toView $ CEvtAgentRcvQueuesDeleted $ L.map rcvQ delQs where rcvQ (connId, server, rcvId, err_) = DeletedRcvQueue (AgentConnId connId) server (AgentQueueId rcvId) err_ processAgentMessage _ _ (DEL_CONNS connIds) = toView $ CEvtAgentConnsDeleted $ L.map AgentConnId connIds processAgentMessage _ "" (ERR e) = eToView $ ChatErrorAgent e (AgentConnId "") Nothing processAgentMessage corrId connId msg = do lockEntity <- critical connId (withStore (`getChatLockEntity` AgentConnId connId)) withEntityLock "processAgentMessage" lockEntity $ do vr <- chatVersionRange -- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here critical connId (withStore' (`getUserByAConnId` AgentConnId connId)) >>= \case Just user -> processAgentMessageConn vr user corrId connId msg `catchAllErrors` eToView _ -> 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 :: ConnId -> CM a -> CM a critical agentConnId a = a `catchAllErrors` \case ChatErrorStore SEDBBusyError {message} -> throwError $ ChatErrorAgent (CRITICAL True message) (AgentConnId agentConnId) Nothing e -> throwError e processAgentMessageNoConn :: AEvent 'AENone -> CM () processAgentMessageNoConn = \case CONNECT p h -> hostEvent $ CEvtHostConnected p h DISCONNECT p h -> hostEvent $ CEvtHostDisconnected p h DOWN srv conns -> serverEvent srv SSPending conns UP srv conns -> serverEvent srv SSActive conns SUSPENDED -> toView CEvtChatSuspended DEL_USER agentUserId -> toView $ CEvtAgentUserDeleted agentUserId ERRS cErrs -> errsEvent $ L.toList cErrs where hostEvent :: ChatEvent -> CM () hostEvent = whenM (asks $ hostEvents . config) . toView serverEvent :: SMPServer -> SubscriptionStatus -> [ConnId] -> CM () serverEvent srv nsStatus conns = toView $ CEvtSubscriptionStatus srv nsStatus $ map AgentConnId conns errsEvent :: [(ConnId, AgentErrorType)] -> CM () errsEvent = toView . CEvtChatErrors . map (\(cId, e) -> ChatErrorAgent e (AgentConnId cId) Nothing) 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 `catchAllErrors` eToView _ -> do lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId where withEntityLock_ :: Maybe ChatRef -> CM a -> CM a withEntityLock_ = \case Just (ChatRef CTDirect contactId _) -> withContactLock "processAgentMsgSndFile" contactId Just (ChatRef CTGroup groupId _scope) -> 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 $ CEvtSndFileProgressXFTP 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 . CEvtSndFileRedirectStartXFTP 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 $ CEvtSndStandaloneFileComplete 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 $ CEvtSndFileProgressXFTP 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, _) -> eToView $ ChatError $ CEInternalError $ "SFDONE, sendFileDescriptions: expected 1 delivery id, got " <> show (length deliveryIds) Left e -> eToView e Nothing -> eToView $ ChatError $ CEInternalError "SFDONE, sendFileDescriptions: expected at least 1 result" lift $ withAgent' (`xftpDeleteSndFileInternal` aFileId) (_, _, SMDSnd, GroupChat g@GroupInfo {groupId} _scope) -> do -- TODO [relays] single description for all recipients ms <- getRecipients 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 $ CEvtSndFileCompleteXFTP user ci' ft where getRecipients | useRelays' g = withStore' $ \db -> getGroupRelayMembers db vr user g | otherwise = withStore' $ \db -> getGroupMembers db vr user g memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') where mConns' = mapMaybe readyMemberConn ms sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts _ -> 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 $ CEvtSndFileWarning 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 $ CEvtChatErrors errs' pure delivered where connDescrEvents :: Int -> NonEmpty (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) connDescrEvents partSize = L.fromList $ concatMap splitText (L.toList connsTransfersDescrs) where splitText :: (Connection, SndFileTransfer, RcvFileDescrText) -> [(Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json))] splitText (conn, _, rfdText) = map (\fileDescr -> (conn, (connOrGroupId, Nothing, XMsgFileDescr {msgId = sharedMsgId, fileDescr}))) (L.toList $ splitFileDescr partSize rfdText) toMsgReq :: (Connection, (ConnOrGroupId, Maybe MsgSigning, ChatMsgEvent 'Json)) -> SndMessage -> ChatMsgReq toMsgReq (conn, _) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgFileDescr_}, (vrValue 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 $ CEvtSndFileError 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 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 `catchAllErrors` eToView _ -> do lift $ withAgent' (`xftpDeleteRcvFile` aFileId) throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId where withEntityLock_ :: Maybe ChatRef -> CM a -> CM a withEntityLock_ = \case Just (ChatRef CTDirect contactId _) -> withContactLock "processAgentMsgRcvFile" contactId Just (ChatRef CTGroup groupId _scope) -> 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 $ CEvtRcvFileProgressXFTP 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 (CEvtRcvStandaloneFileComplete user fsTargetPath ft) (CEvtRcvFileComplete user) ci_ RFWARN e -> do ci <- withStore $ \db -> do liftIO $ updateCIFileStatus db user fileId (CIFSRcvWarning $ agentFileError e) lookupChatItemByFileId db vr user fileId toView $ CEvtRcvFileWarning 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 $ CEvtChatItemUpdated 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 $ CEvtRcvFileError user aci_ e ft type ShouldDeleteGroupConns = Bool 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 agentConnId $ withStore (\db -> getConnectionEntity db vr user $ AgentConnId agentConnId) >>= updateConnStatus case agentMessage of END -> case entity of RcvDirectMsgConnection _ (Just ct) -> toView $ CEvtContactAnotherClient user ct _ -> toView $ CEvtSubscriptionEnd user entity MSGNTF msgId msgTs_ -> toView $ CEvtNtfMessage 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 UserContactConnection conn uc -> processContactConnMessage agentMessage entity conn uc where updateConnStatus :: ConnectionEntity -> CM ConnectionEntity updateConnStatus acEntity = case agentMsgConnStatus (entityConnection acEntity) agentMessage of Just connStatus -> do let conn = (entityConnection acEntity) {connStatus} withStore' $ \db -> updateConnectionStatus db conn connStatus pure $ updateEntityConnStatus acEntity connStatus Nothing -> pure acEntity agentMsgConnStatus :: Connection -> AEvent e -> Maybe ConnStatus agentMsgConnStatus Connection {connStatus = cs} = \case JOINED True _ -> Just ConnSndReady CONF {} -> Just ConnRequested INFO {} -> Just ConnSndReady CON _ -> Just ConnReady ERR err | cs /= ConnReady && not (temporaryOrHostError err) -> Just $ ConnFailed (tshow err) _ -> 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'', gInfo_) <- saveConnInfo conn' connInfo incognitoProfile <- forM customUserProfileId $ \profileId -> withStore (\db -> getProfileById db userId profileId) let profileToSend = case gInfo_ of Just gInfo -> userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) Nothing -> userProfileDirect user (fromLocalProfile <$> incognitoProfile) Nothing True -- [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 () -- TODO [certs rcv] JOINED _ _serviceId -> -- [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 eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) processConnMERR connEntity conn err MERRS _ err -> do -- error cannot be AUTH error here eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) ERR err -> do eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () -- TODO add debugging output _ -> pure () Just ct@Contact {contactId} -> case agentMsg of -- TODO [certs rcv] INV (ACR _ cReq) _serviceId -> -- [async agent commands] XGrpMemIntro continuation on receiving INV withCompletedCommand conn agentMsg $ \_ -> case cReq of CRInvitationUri _ _ -> withStore' $ \db -> setConnConnReqInv db user connId cReq 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 `catchAllErrors` \_ -> pure () forM_ aChatMsgs $ \case Right (APMsg _ (ParsedMsg _ _ chatMsg)) -> processEvent ct' conn' tags eInfo chatMsg `catchAllErrors` \e -> eToView e Left e -> do atomically $ modifyTVar' tags ("error" :) logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) withRcpt <- checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent pure (withRcpt, False) 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 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 _msgScope _ -> 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 -> [AParsedMsg] -> CM Bool checkSendRcpt ct' aMsgs = do let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs where aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ 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 `catchAllErrors` const (pure ct) -- [incognito] send incognito profile incognitoProfile <- forM customUserProfileId $ \profileId -> withStore $ \db -> getProfileById db userId profileId let p = userProfileDirect user (fromLocalProfile <$> incognitoProfile) (Just ct') True 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 void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend toView $ CEvtBusinessLinkConnecting 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 -> do let prepared = isJust (preparedContact ct) || isJust (contactRequestId' ct) void $ processContactProfileUpdate ct profile prepared XOk -> pure () _ -> messageError "INFO for existing contact must have x.grp.mem.info, x.info or x.ok" CON pqEnc -> 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) toView $ CEvtContactConnected user ct' (fmap fromLocalProfile incognitoProfile) let createE2EItem = createInternalChatItem user (CDDirectRcv ct') (CIRcvDirectE2EEInfo $ E2EInfo $ Just pqEnc) Nothing -- TODO [short links] get contact request by contactRequestId, check encryption (UserContactRequest.pqSupport)? when (directOrUsed ct') $ case (preparedContact ct', contactRequestId' ct') of (Nothing, Nothing) -> do unlessM (withStore' $ \db -> checkContactHasItems db user ct') $ createInternalChatItem user (CDDirectSnd ct') CIChatBanner (Just epochStart) createE2EItem createFeatureEnabledItems user ct' (Just PreparedContact {connLinkToConnect = ACCL _ (CCLink cReq _)}, _) -> unless (Just pqEnc == connRequestPQEncryption cReq) createE2EItem (_, Just connReqId) -> withStore' (\db -> getContactRequest' db user connReqId) >>= \case Just UserContactRequest {pqSupport} | CR.pqSupportToEnc pqSupport == pqEnc -> pure () _ -> createE2EItem when (contactConnInitiated conn') $ do probeMatchingMembers ct' (contactConnIncognito ct') withStore' $ \db -> resetContactConnInitiated db user conn' forM_ viaUserContactLink $ \userContactLinkId -> do (ucl, gli_) <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId -- let UserContactLink {addressSettings = AddressSettings {autoReply}} = ucl when (connChatVersion < batchSend2Version) $ forM_ (autoReply $ addressSettings ucl) $ \mc -> sendAutoReply ct' mc Nothing -- old versions only -- TODO REMOVE LEGACY vvv forM_ gli_ $ \GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> 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 -- TODO REMOVE LEGACY ^^^ 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 $ CEvtChatItemsStatusesUpdated user acis where ctItem = AChatItem SCTDirect SMDSnd (DirectChat ct) SWITCH qd phase cStats -> do toView $ CEvtContactSwitch 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 $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci) _ -> do toView $ CEvtContactRatchetSync user ct (RatchetSyncProgress rss cStats) createInternalChatItem user (CDDirectRcv ct) (CIRcvDecryptionError mde n) Nothing ratchetSyncEventItem ct' = do toView $ CEvtContactRatchetSync 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 () -- TODO [certs rcv] JOINED sqSecured _serviceId -> -- [async agent commands] continuation on receiving JOINED when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> when (directOrUsed ct && sqSecured) $ do toView $ CEvtContactSndReady user ct when (connChatVersion >= batchSend2Version) $ forM_ viaUserContactLink $ \userContactLinkId -> do (ucl, _) <- withStore $ \db -> getUserContactLinkById db userId userContactLinkId forM_ (autoReply $ addressSettings ucl) $ \mc -> do connReq_ <- pure (contactRequestId' ct) $>>= \connReqId -> withStore' (\db -> getContactRequest' db user connReqId) sendAutoReply ct mc connReq_ 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) eToView $ ChatErrorAgent err (AgentConnId agentConnId) (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) eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) ERR err -> do eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () -- TODO add debugging output _ -> pure () where sendAutoReply ct mc = \case Just UserContactRequest {welcomeSharedMsgId = Just smId} -> void $ sendDirectContactMessage user ct $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do (msg, _) <- sendDirectContactMessage user ct $ XMsgNew $ MCSimple $ extMsgContent mc Nothing ci <- saveSndChatItem user (CDDirectSnd ct) msg (CISndMsgContent mc) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDSnd (DirectChat ct) ci] processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM () processGroupMessage agentMsg connEntity conn@Connection {connId, connChatVersion, customUserProfileId, connectionCode} gInfo@GroupInfo {groupId, groupProfile, membership, chatSettings} m = case agentMsg of -- TODO [certs rcv] INV (ACR _ cReq) _serviceId -> 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 -> messageError "processGroupMessage INV: member chat version range incompatible" 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} -- TODO REMOVE LEGACY vvv -- [async agent commands] group link auto-accept continuation on receiving INV CFCreateConnGrpInv -> do (ct, groupLinkId) <- withStore $ \db -> do ct <- getContactViaMember db vr user m liftIO $ setNewContactMemberConnRequest db user m cReq liftIO $ (ct,) <$> getGroupLinkId db user gInfo sendGrpInvitation ct m groupLinkId toView $ CEvtSentGroupInvitation user gInfo ct m where sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM () sendGrpInvitation ct GroupMember {memberId, memberRole = memRole} groupLinkId = do let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo 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 Nothing m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing -- TODO REMOVE LEGACY ^^^ _ -> 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" XGrpRelayAcpt relayLink memberKey | memberRole' membership == GROwner && isRelay m -> do withStore $ \db -> do relay <- getGroupRelayByGMId db (groupMemberId' m) liftIO $ updateGroupMemberStatus db userId m GSMemAccepted void $ liftIO $ setRelayLinkAccepted db relay relayLink memberKey allowAgentConnectionAsync user conn' confId XOk | otherwise -> messageError "x.grp.relay.acpt: only owner can add relay" _ -> messageError "CONF from invited member must have x.grp.acpt" GCHostMember -> case chatMsgEvent of XGrpLinkInv glInv@GroupLinkInvitation {groupProfile = GroupProfile {sharedGroupId = rcvGId}} -> do -- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records let GroupInfo {groupProfile = GroupProfile {sharedGroupId = curGId}} = gInfo when (rcvGId /= curGId) $ messageError "x.grp.link.inv: sharedGroupId mismatch" (gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersInvited db vr user gInfo m glInv -- [incognito] send saved profile incognitoProfile <- forM customUserProfileId $ \pId -> withStore (\db -> getProfileById db userId pId) let profileToSend = userProfileInGroup user gInfo (fromLocalProfile <$> incognitoProfile) allowAgentConnectionAsync user conn' confId $ XInfo profileToSend toView $ CEvtGroupLinkConnecting user gInfo' m' XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do (gInfo', m') <- withStore $ \db -> updatePreparedUserAndHostMembersRejected db vr user gInfo m glRjct toView $ CEvtGroupLinkConnecting user gInfo' m' toViewTE $ TEGroupLinkRejected user gInfo' rejectionReason _ -> messageError "CONF from host member in prepared group must have x.grp.link.inv or x.grp.link.reject" _ -> case chatMsgEvent of XGrpMemInfo memId _memProfile | sameMemberId memId m -> do let GroupMember {memberId = membershipMemId} = membership allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo membershipProfile = redactedMemberProfile allowSimplexLinks $ 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" -- sent when connecting via group link XInfo _ -> -- TODO Keep rejected member to allow them to appeal against rejection. when (memberStatus m == GSMemRejected) $ do deleteMemberConnection' m True withStore' $ \db -> deleteGroupMember db user m XOk -> pure () _ -> messageError "INFO from member must have x.grp.mem.info, x.info or x.ok" pure () CON _pqEnc -> unless (memberStatus m == GSMemRejected || memberStatus membership == GSMemRejected) $ do -- TODO [knocking] send pending messages after accepting? -- possible improvement: check for each pending message, requires keeping track of connection state unless (connDisabled conn) $ sendPendingGroupMessages user gInfo m conn withAgent $ \a -> toggleConnectionNtfs a (aConnId conn) $ chatHasNtfs chatSettings case memberCategory m of GCHostMember -> do (m', gInfo') <- withStore' $ \db -> do updateGroupMemberStatus db userId m GSMemConnected gInfo' <- if not (memberPending membership) then do updateGroupMemberStatus db userId membership GSMemConnected pure gInfo {membership = membership {memberStatus = GSMemConnected}} else pure gInfo pure (m {memberStatus = GSMemConnected}, gInfo') toView $ CEvtUserJoinedGroup user gInfo' m' (gInfo'', m'', scopeInfo) <- mkGroupChatScope gInfo' m' -- Create e2ee, feature and group description chat items only on first connected relay ifM firstConnectedHost ( do let cd = CDGroupRcv gInfo'' scopeInfo m'' createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing let prepared = preparedGroup gInfo'' unless (isJust prepared) $ createGroupFeatureItems user cd CIRcvGroupFeature gInfo'' memberConnectedChatItem gInfo'' scopeInfo m'' let welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId = mId} -> mId) <$> prepared unless (memberPending membership || isJust welcomeMsgId_) $ maybeCreateGroupDescrLocal gInfo'' m'' ) (memberConnectedChatItem gInfo'' scopeInfo m'') where firstConnectedHost | useRelays' gInfo = do relayMems <- withStore' $ \db -> getGroupRelayMembers db vr user gInfo let numConnected = length $ filter (\GroupMember {memberStatus = ms} -> ms == GSMemConnected) relayMems pure $ numConnected == 1 | otherwise = pure True GCInviteeMember | isRelay m -> do withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected gLink <- withStore $ \db -> getGroupLink db user gInfo setGroupLinkDataAsync user gInfo gLink | otherwise -> do (gInfo', mStatus) <- if not (memberPending m) then do mStatus <- withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected $> GSMemConnected pure (gInfo, mStatus) else do gInfo' <- withStore' $ \db -> increaseGroupMembersRequireAttention db user gInfo pure (gInfo', memberStatus m) (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo' m memberConnectedChatItem gInfo'' scopeInfo m' case scopeInfo of Just (GCSIMemberSupport _) -> do createInternalChatItem user (CDGroupRcv gInfo'' scopeInfo m') (CIRcvGroupEvent RGENewMemberPendingReview) Nothing _ -> pure () toView $ CEvtJoinedGroupMember user gInfo'' m' {memberStatus = mStatus} let Connection {viaUserContactLink} = conn when (isJust viaUserContactLink && isNothing (memberContactId m')) $ sendXGrpLinkMem gInfo'' when (connChatVersion < batchSend2Version) $ getAutoReplyMsg >>= mapM_ (\mc -> sendGroupAutoReply mc Nothing) if useRelays' gInfo'' then do introduceInChannel vr user gInfo'' m' when (groupFeatureAllowed SGFHistory gInfo'') $ sendHistory user gInfo'' m' else case mStatus of GSMemPendingApproval -> pure () GSMemPendingReview -> introduceToModerators vr user gInfo'' m' _ -> do introduceToAll vr user gInfo'' m' let memberIsCustomer = case businessChat gInfo'' of Just BusinessChatInfo {chatType = BCCustomer, customerId} -> memberId' m' == customerId _ -> False when (groupFeatureAllowed SGFHistory gInfo'' && not memberIsCustomer) $ sendHistory user gInfo'' m' where sendXGrpLinkMem gInfo'' = do let GroupInfo {membership = membership'} = gInfo'' incognitoProfile = ExistingIncognito <$> incognitoMembershipProfile gInfo'' profileToSend = userProfileInGroup user gInfo (fromIncognitoProfile <$> incognitoProfile) memberKey = MemberKey <$> memberPubKey membership' void $ sendDirectMemberMessage conn (XGrpLinkMem profileToSend memberKey) groupId _ -> do unless (memberPending m) $ withStore' $ \db -> updateGroupMemberStatus db userId m GSMemConnected notifyMemberConnected gInfo m Nothing let memCategory = memberCategory m connectedIncognito = memberIncognito membership when (memCategory == GCPreMember) $ probeMatchingMemberContact m connectedIncognito 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 -- possible improvement is to choose scope based on event (some events specify scope) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> pure () newDeliveryTasks <- reverse <$> foldM (processAChatMsg gInfo' scopeInfo m' tags eInfo) [] aChatMsgs shouldDelConns <- if isUserGrpFwdRelay gInfo' && not (blockedByAdmin m) then createDeliveryTasks gInfo' m' newDeliveryTasks else pure False withRcpt <- checkSendRcpt $ rights aChatMsgs pure (withRcpt, shouldDelConns) where aChatMsgs = parseChatMessages msgBody brokerTs = metaBrokerTs msgMeta processAChatMsg :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> TVar [Text] -> Text -> [NewMessageDeliveryTask] -> Either String AParsedMsg -> CM [NewMessageDeliveryTask] processAChatMsg gInfo' scopeInfo m' tags eInfo newDeliveryTasks = \case Right (APMsg enc (parsedMsg@(ParsedMsg fwd_ _ ChatMessage {chatMsgEvent}))) -> do let tag = toCMEventTag chatMsgEvent atomically $ modifyTVar' tags (tshow tag :) case fwd_ of Just fwd | SJson <- enc -> do logInfo $ "group fwd=" <> tshow tag <> " " <> eInfo xGrpMsgForward gInfo' scopeInfo m' fwd parsedMsg brokerTs `catchAllErrors` \e -> eToView e pure newDeliveryTasks -- direct JSON and binary messages; binary events don't produce delivery tasks _ -> do logInfo $ "group msg=" <> tshow tag <> " " <> eInfo newTask_ <- join <$> withVerifiedMsg gInfo' scopeInfo m' parsedMsg brokerTs (\verifiedMsg -> processEvent gInfo' m' verifiedMsg `catchAllErrors` \e -> eToView e $> Nothing) pure $ maybe id (:) newTask_ newDeliveryTasks Left e -> do atomically $ modifyTVar' tags ("error" :) logInfo $ "group msg=error " <> eInfo <> " " <> tshow e eToView (ChatError . CEException $ "error parsing chat message: " <> e) pure newDeliveryTasks processEvent :: forall e. MsgEncodingI e => GroupInfo -> GroupMember -> VerifiedMsg e -> CM (Maybe NewMessageDeliveryTask) processEvent gInfo' m' verifiedMsg = do (m'', conn', msg@RcvMessage {msgId, chatMsgEvent = ACME _ event}) <- saveGroupRcvMsg user groupId m' conn msgMeta verifiedMsg let ctx js = DeliveryTaskContext js False checkSendAsGroup :: Maybe Bool -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) checkSendAsGroup asGroup_ a | asGroup_ == Just True && memberRole' m'' < GROwner = messageError "member is not allowed to send as group" $> Nothing | otherwise = a -- ! see isForwardedGroupMsg: processing functions should return DeliveryJobScope for same events deliveryTaskContext_ <- case event of XMsgNew mc -> checkSendAsGroup asGroup $ memberCanSend (Just m'') scope $ newGroupContentMessage gInfo' (Just m'') mc msg brokerTs False where ExtMsgContent {scope, asGroup} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' (Just m'') sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> checkSendAsGroup asGroup_ $ memberCanSend (Just m'') msgScope $ groupMessageUpdate gInfo' (Just m'') sharedMsgId mContent mentions msgScope msg brokerTs ttl live asGroup_ XMsgDel sharedMsgId memberId_ scope_ -> groupMessageDelete gInfo' (Just m'') sharedMsgId memberId_ scope_ msg brokerTs XMsgReact sharedMsgId memberId scope_ reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId scope_ reaction add msg brokerTs -- TODO discontinue XFile XFile fInv -> Nothing <$ processGroupFileInvitation' gInfo' m'' fInv msg brokerTs XFileCancel sharedMsgId -> xFileCancelGroup gInfo' (Just m'') sharedMsgId XFileAcptInv sharedMsgId fileConnReq_ fName -> Nothing <$ xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName XInfo p -> fmap ctx <$> xInfoMember gInfo' m'' p msg brokerTs XGrpLinkMem p memberKey -> Nothing <$ xGrpLinkMem gInfo' m'' conn' p memberKey XGrpLinkAcpt acceptance role memberId -> Nothing <$ xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs XGrpMemNew memInfo msgScope -> fmap ctx <$> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs XGrpMemIntro memInfo memRestrictions_ -> Nothing <$ xGrpMemIntro gInfo' m'' memInfo memRestrictions_ XGrpMemInv memId introInv -> Nothing <$ xGrpMemInv gInfo' m'' memId introInv XGrpMemFwd memInfo introInv -> Nothing <$ xGrpMemFwd gInfo' m'' memInfo introInv XGrpMemRole memId memRole -> fmap ctx <$> xGrpMemRole gInfo' m'' memId memRole msg brokerTs XGrpMemRestrict memId memRestrictions -> fmap ctx <$> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs XGrpMemCon memId -> Nothing <$ xGrpMemCon gInfo' m'' memId XGrpMemDel memId withMessages -> case encoding @e of SJson -> fmap ctx <$> xGrpMemDel gInfo' m'' memId withMessages verifiedMsg msg brokerTs False SBinary -> pure Nothing XGrpLeave -> fmap ctx <$> xGrpLeave gInfo' m'' msg brokerTs XGrpDel -> Just (DeliveryTaskContext (DJSGroup {jobSpec = DJRelayRemoved}) False) <$ xGrpDel gInfo' m'' msg brokerTs XGrpInfo p' -> fmap ctx <$> xGrpInfo gInfo' m'' p' msg brokerTs XGrpPrefs ps' -> fmap ctx <$> xGrpPrefs gInfo' m'' ps' msg -- TODO [knocking] why don't we forward these messages? XGrpDirectInv connReq mContent_ msgScope -> memberCanSend (Just m'') msgScope $ Nothing <$ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs XGrpMsgForward fwd msg' -> Nothing <$ xGrpMsgForward gInfo' Nothing m'' fwd (ParsedMsg Nothing Nothing msg') brokerTs XInfoProbe probe -> Nothing <$ xInfoProbe (COMGroupMember m'') probe XInfoProbeCheck probeHash -> Nothing <$ xInfoProbeCheck (COMGroupMember m'') probeHash XInfoProbeOk probe -> Nothing <$ xInfoProbeOk (COMGroupMember m'') probe BFileChunk sharedMsgId chunk -> Nothing <$ bFileChunkGroup gInfo' sharedMsgId chunk msgMeta _ -> Nothing <$ messageError ("unsupported message: " <> tshow event) forM deliveryTaskContext_ $ \taskContext -> pure $ NewMessageDeliveryTask {messageId = msgId, taskContext} checkSendRcpt :: [AParsedMsg] -> CM Bool checkSendRcpt aMsgs = do let currentMemCount = fromIntegral $ currentMembers $ groupSummary gInfo GroupInfo {chatSettings = ChatSettings {sendRcpts}} = gInfo pure $ fromMaybe (sendRcptsSmallGroups user) sendRcpts && any aChatMsgHasReceipt aMsgs && currentMemCount <= smallGroupsRcptsMemLimit where aChatMsgHasReceipt (APMsg _ (ParsedMsg _ _ ChatMessage {chatMsgEvent})) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) createDeliveryTasks :: GroupInfo -> GroupMember -> [NewMessageDeliveryTask] -> CM ShouldDeleteGroupConns createDeliveryTasks gInfo'@GroupInfo {groupId = gId} m' newDeliveryTasks = do let relayRemovedTask_ = find (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> isRelayRemoved jobScope) newDeliveryTasks createdDeliveryTasks <- case relayRemovedTask_ of Nothing -> do withStore' $ \db -> forM_ newDeliveryTasks $ \newTask -> createMsgDeliveryTask db gInfo' m' newTask pure newDeliveryTasks Just relayRemovedTask -> do -- if relay is removed, delete all other tasks and jobs withStore' $ \db -> do deleteGroupDeliveryTasks db gInfo' deleteGroupDeliveryJobs db gInfo' createMsgDeliveryTask db gInfo' m' relayRemovedTask pure [relayRemovedTask] lift $ forM_ (uniqueWorkerScopes createdDeliveryTasks) $ \workerScope -> getDeliveryTaskWorker True (gId, workerScope) pure $ isJust relayRemovedTask_ where uniqueWorkerScopes :: [NewMessageDeliveryTask] -> [DeliveryWorkerScope] uniqueWorkerScopes createdDeliveryTasks = let workerScopes = map (\NewMessageDeliveryTask {taskContext = DeliveryTaskContext {jobScope}} -> toWorkerScope jobScope) createdDeliveryTasks in foldr' addWorkerScope [] workerScopes where addWorkerScope workerScope acc | workerScope `elem` acc = acc | otherwise = workerScope : acc 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 gInfo m conn SWITCH qd phase cStats -> do toView $ CEvtGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m when (phase == SPStarted || phase == SPCompleted) $ case qd of QDRcv -> createInternalChatItem user (CDGroupSnd gInfo' scopeInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m') Nothing QDSnd -> createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m') (CIRcvConnEvent $ RCESwitchQueue phase) Nothing RSYNC rss cryptoErr_ cStats -> do (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m case (rss, connectionCode, cryptoErr_) of (RSRequired, _, Just cryptoErr) -> processErr gInfo' scopeInfo m' cryptoErr (RSAllowed, _, Just cryptoErr) -> processErr gInfo' scopeInfo m' cryptoErr (RSAgreed, Just _, _) -> do withStore' $ \db -> setConnectionVerified db user connId Nothing let m'' = m' {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember ratchetSyncEventItem gInfo' scopeInfo m'' toViewTE $ TEGroupMemberVerificationReset user gInfo' m'' createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m'') (CIRcvConnEvent RCEVerificationCodeReset) Nothing _ -> ratchetSyncEventItem gInfo' scopeInfo m' where processErr gInfo' scopeInfo m' 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 $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo' scopeInfo) ci) _ -> do toView $ CEvtGroupMemberRatchetSync user gInfo' m' (RatchetSyncProgress rss cStats) createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m') (CIRcvDecryptionError mde n) Nothing ratchetSyncEventItem gInfo' scopeInfo m' = do toView $ CEvtGroupMemberRatchetSync user gInfo' m' (RatchetSyncProgress rss cStats) createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing OK -> -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () -- TODO [certs rcv] JOINED sqSecured _serviceId -> -- [async agent commands] continuation on receiving JOINED when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> when (sqSecured && connChatVersion >= batchSend2Version) $ do mc_ <- getAutoReplyMsg forM_ mc_ $ \mc -> do connReq_ <- withStore' $ \db -> getBusinessContactRequest db user groupId sendGroupAutoReply mc connReq_ LDATA FixedLinkData {linkConnReq = cReq} _cData -> -- [async agent commands] CFGetConnShortLink continuation - join relay connection with resolved link withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> case cmdFunction of CFGetShortLink -> case cReq of CRContactUri crData@ConnReqUriData {crClientData} -> do let pqSup = PQSupportOff lift (withAgent' $ \a -> connRequestPQSupport a pqSup cReq) >>= \case Nothing -> throwChatError CEInvalidConnReq Just (agentV, _) -> do let chatV = agentToChatVersion agentV groupLinkId = crClientData >>= decodeJSON >>= \(CRDataGroup gli) -> Just gli cReqHash = contactCReqHash $ CRContactUri crData {crScheme = SSSimplex} -- Update connection with data derived from cReq, now available after getConnShortLinkAsync withStore' $ \db -> updateConnLinkData db user conn cReq cReqHash groupLinkId chatV pqSup let GroupMember {memberId = membershipMemId} = membership incognitoProfile = fromLocalProfile <$> incognitoMembershipProfile gInfo profileToSend = userProfileInGroup user gInfo incognitoProfile memberPubKey <- case groupKeys gInfo of Just GroupKeys {memberPrivKey} -> pure $ C.publicKey memberPrivKey Nothing -> throwChatError $ CEInternalError "no group keys for channel membership" dm <- encodeConnInfo $ XMember profileToSend membershipMemId (MemberKey memberPubKey) subMode <- chatReadVar subscriptionMode void $ joinAgentConnectionAsync user (Just conn) True cReq dm subMode _ -> throwChatError $ CECommandError "unexpected cmdFunction" QCONT -> do continued <- continueSending connEntity conn when continued $ sendPendingGroupMessages user gInfo 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 -- eToView $ ChatErrorAgent err (AgentConnId agentConnId) (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 () eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) ERR err -> do eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () when (isConnFailed $ connStatus conn) $ toView $ CEvtGroupMemberUpdated user gInfo m m -- 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 getAutoReplyMsg = 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 {addressSettings = AddressSettings {autoReply}} = autoReply _ -> pure Nothing sendGroupAutoReply mc = \case Just UserContactRequest {welcomeSharedMsgId = Just smId} -> void $ sendGroupMessage' user gInfo [m] $ XMsgUpdate smId mc M.empty Nothing Nothing Nothing Nothing _ -> do msg <- sendGroupMessage' user gInfo [m] $ XMsgNew $ MCSimple $ extMsgContent mc Nothing ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndMsgContent mc) withStore' $ \db -> createGroupSndStatus db (chatItemId' ci) (groupMemberId' m) GSSNew toView $ CEvtNewChatItems user [AChatItem SCTGroup SMDSnd (GroupChat gInfo Nothing) 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 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 ci <- withStore $ \db -> getChatItemByFileId db vr user fileId toView $ CEvtRcvFileSndCancelled 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 $ CEvtRcvFileComplete user ci mapM_ (deleteAgentConnectionAsync . aConnId) conn_ RcvChunkDuplicate -> withAckMessage' "file msg" agentConnId meta $ pure () RcvChunkError -> badRcvFileChunk ft $ "incorrect chunk number " <> show chunkNo processContactConnMessage :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM () processContactConnMessage agentMsg connEntity conn UserContact {userContactLinkId = uclId, groupId = ucGroupId_} = case agentMsg of REQ invId pqSupport _ connInfo -> do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage conn connInfo case chatMsgEvent of XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport XMember p joiningMemberId joiningMemberKey -> memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport XGrpRelayInv groupRelayInv -> xGrpRelayInv invId chatVRange groupRelayInv -- TODO show/log error, other events in contact request _ -> pure () LINK _link auData -> withCompletedCommand conn agentMsg $ \CommandData {cmdFunction} -> case cmdFunction of CFSetShortLink -> case (ucGroupId_, auData) of (Just groupId, UserContactLinkData UserContactData {relays = relayLinks}) -> do (gInfo, gLink, relays, relaysChanged) <- withStore $ \db -> do gInfo <- getGroupInfo db vr user groupId gLink <- getGroupLink db user gInfo relays <- liftIO $ getGroupRelays db gInfo (relays', changed) <- liftIO $ foldrM (updateRelay db) ([], False) relays liftIO $ setGroupInProgressDone db gInfo pure (gInfo, gLink, relays', changed) toView $ CEvtGroupLinkDataUpdated user gInfo gLink relays relaysChanged where -- TODO [relays] owner: on relay deletion (link absent from relayLinks) -- TODO move status RSActive to new "Removed" status / remove relay record updateRelay :: DB.Connection -> GroupRelay -> ([GroupRelay], Bool) -> IO ([GroupRelay], Bool) updateRelay db relay@GroupRelay {relayLink, relayStatus} (acc, changed) = case relayLink of Just rLink | rLink `elem` relayLinks && relayStatus == RSAccepted -> do relay' <- updateRelayStatus db relay RSActive pure (relay' : acc, True) _ -> pure (relay : acc, changed) _ -> throwChatError $ CECommandError "LINK event expected for a group link only" _ -> throwChatError $ CECommandError "unexpected cmdFunction" MERR _ err -> do eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) processConnMERR connEntity conn err ERR err -> do eToView $ ChatErrorAgent err (AgentConnId agentConnId) (Just connEntity) when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () -- TODO add debugging output _ -> pure () where profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> Maybe (SharedMsgId, MsgContent) -> PQSupport -> CM () profileContactRequest invId chatVRange p@Profile {displayName} xContactId_ welcomeMsgId_ requestMsg_ reqPQSup = do (ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId let v = maxVersion chatVRange case gLinkInfo_ of -- ##### Contact requests (regular and business contacts) ##### Nothing -> do let UserContactLink {connLinkContact = CCLink connReq _, shortLinkDataSet, addressSettings} = ucl AddressSettings {autoAccept} = addressSettings isSimplexTeam = sameConnReqContact connReq adminContactReq gVar <- asks random withStore (\db -> createOrUpdateContactRequest db gVar vr user uclId ucl isSimplexTeam invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ reqPQSup) >>= \case RSAcceptedRequest _ucr re -> case re of REContact ct -> -- TODO [short links] update request msg toView $ CEvtContactRequestAlreadyAccepted user ct REBusinessChat gInfo _clientMember -> -- TODO [short links] update request msg toView $ CEvtBusinessRequestAlreadyAccepted user gInfo RSCurrentRequest prevUcr_ ucr@UserContactRequest {welcomeSharedMsgId} re_ -> case re_ of Nothing -> toView $ CEvtReceivedContactRequest user ucr Nothing Just (REContact ct) -> do let cd = CDDirectRcv ct aci_ <- case prevUcr_ of Just UserContactRequest {requestSharedMsgId = prevSharedMsgId_} -> -- TODO [short links] this branch does not update feature items and e2e items, as they are highly unlikely to change -- they will be updated after connection is accepted. upsertDirectRequestItem cd (requestMsg_, prevSharedMsgId_) Nothing -> do void $ createChatItem user (CDDirectSnd ct) False CIChatBanner Nothing (Just epochStart) let e2eContent = CIRcvDirectE2EEInfo $ E2EInfo $ Just $ CR.pqSupportToEnc $ reqPQSup void $ createChatItem user cd False e2eContent Nothing Nothing void $ createFeatureEnabledItems_ user ct forM_ (autoReply addressSettings) $ \mc -> forM_ welcomeSharedMsgId $ \sharedMsgId -> createChatItem user (CDDirectSnd ct) False (CISndMsgContent mc) (Just sharedMsgId) Nothing mapM (createRequestItem cd) requestMsg_ case autoAccept of Nothing -> do let cInfo = DirectChat ct chat = AChat SCTDirect $ case aci_ of Just (AChatItem SCTDirect dir _ ci) -> Chat cInfo [CChatItem dir ci] emptyChatStats {unreadCount = 1, minUnreadItemId = chatItemId' ci} _ -> Chat cInfo [] emptyChatStats toView $ CEvtReceivedContactRequest user ucr $ Just chat Just AutoAccept {acceptIncognito} -> do incognitoProfile <- if not shortLinkDataSet && acceptIncognito then Just . NewIncognito <$> liftIO generateRandomProfile else pure Nothing ct' <- acceptContactRequestAsync user uclId ct ucr incognitoProfile toView $ CEvtAcceptingContactRequest user ct' Just (REBusinessChat gInfo clientMember) -> do (_gInfo', _clientMember') <- acceptBusinessJoinRequestAsync user uclId gInfo clientMember ucr let cd = CDGroupRcv gInfo Nothing clientMember void $ case prevUcr_ of Just UserContactRequest {requestSharedMsgId = prevSharedMsgId_} -> -- TODO [short links] this branch does not update feature items and e2e items, as they are highly unlikely to change -- they will be updated after connection is accepted. upsertBusinessRequestItem cd (requestMsg_, prevSharedMsgId_) Nothing -> do void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) -- TODO [short links] possibly, we can just keep them created where they are created on the business side due to auto-accept -- let e2eContent = CIRcvGroupE2EEInfo $ E2EInfo $ Just False -- no PQ encryption in groups -- void $ createChatItem user cd False e2eContent Nothing Nothing -- void $ createFeatureEnabledItems_ user ct forM_ (autoReply addressSettings) $ \arMC -> forM_ welcomeSharedMsgId $ \sharedMsgId -> createChatItem user (CDGroupSnd gInfo Nothing) False (CISndMsgContent arMC) (Just sharedMsgId) Nothing mapM (createRequestItem cd) requestMsg_ toView $ CEvtAcceptingBusinessRequest user gInfo where upsertDirectRequestItem :: ChatDirection 'CTDirect 'MDRcv -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem) upsertDirectRequestItem cd@(CDDirectRcv ct@Contact {contactId}) = upsertRequestItem cd updateRequestItem markRequestItemDeleted where updateRequestItem (sharedMsgId, mc) = withStore (\db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId) >>= \case CChatItem SMDRcv ci@ChatItem {content = CIRcvMsgContent oldMC} | mc /= oldMC -> do currentTs <- liftIO getCurrentTime aci <- withStore' $ \db -> do addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (currentTs, mc) aChatItem <$> updateDirectChatItem' db user contactId ci (CIRcvMsgContent mc) True False Nothing Nothing toView $ CEvtChatItemUpdated user aci pure $ Just aci | otherwise -> pure $ Just $ aChatItem ci _ -> pure Nothing where aChatItem = AChatItem SCTDirect SMDRcv (DirectChat ct) markRequestItemDeleted sharedMsgId = withStore' (\db -> runExceptT $ getDirectChatItemBySharedMsgId db user contactId sharedMsgId) >>= \case Right (cci@(CChatItem SMDRcv _)) -> do currentTs <- liftIO getCurrentTime deletions <- if featureAllowed SCFFullDelete forContact ct then deleteDirectCIs user ct [cci] else markDirectCIsDeleted user ct [cci] currentTs toView $ CEvtChatItemsDeleted user deletions False False _ -> pure () upsertBusinessRequestItem :: ChatDirection 'CTGroup 'MDRcv -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem) upsertBusinessRequestItem cd@(CDGroupRcv gInfo@GroupInfo {groupId} _ clientMember) = upsertRequestItem cd updateRequestItem markRequestItemDeleted where updateRequestItem (sharedMsgId, mc) = withStore (\db -> getGroupChatItemBySharedMsgId db user gInfo (Just $ groupMemberId' clientMember) sharedMsgId) >>= \case CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', content = CIRcvMsgContent oldMC} | sameMemberId (memberId' clientMember) m' -> if mc /= oldMC then do currentTs <- liftIO getCurrentTime aci <- withStore' $ \db -> do addInitialAndNewCIVersions db (chatItemId' ci) (chatItemTs' ci, oldMC) (currentTs, mc) aChatItem <$> updateGroupChatItem db user groupId ci (CIRcvMsgContent mc) True False Nothing toView $ CEvtChatItemUpdated user aci pure $ Just aci else pure $ Just $ aChatItem ci _ -> pure Nothing where aChatItem = AChatItem SCTGroup SMDRcv (GroupChat gInfo Nothing) markRequestItemDeleted sharedMsgId = withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo (memberId' clientMember) sharedMsgId) >>= \case Right cci@(CChatItem SMDRcv ChatItem {chatDir = CIGroupRcv m'}) | sameMemberId (memberId' clientMember) m' -> do currentTs <- liftIO getCurrentTime deletions <- if groupFeatureMemberAllowed SGFFullDelete clientMember gInfo then deleteGroupCIs user gInfo Nothing [cci] Nothing currentTs else markGroupCIsDeleted user gInfo Nothing [cci] Nothing currentTs toView $ CEvtChatItemsDeleted user deletions False False _ -> pure () upsertBusinessRequestItem (CDChannelRcv _ _) = const $ pure Nothing createRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> (SharedMsgId, MsgContent) -> CM AChatItem createRequestItem cd (sharedMsgId, mc) = do aci <- createChatItem user cd False (CIRcvMsgContent mc) (Just sharedMsgId) Nothing toView $ CEvtNewChatItems user [aci] pure aci upsertRequestItem :: ChatTypeI c => ChatDirection c 'MDRcv -> ((SharedMsgId, MsgContent) -> CM (Maybe AChatItem)) -> (SharedMsgId -> CM ()) -> (Maybe (SharedMsgId, MsgContent), Maybe SharedMsgId) -> CM (Maybe AChatItem) upsertRequestItem cd update delete = \case (Just msg, Nothing) -> Just <$> createRequestItem cd msg (Just msg@(sharedMsgId, _), Just prevSharedMsgId) | sharedMsgId == prevSharedMsgId -> update msg `catchCINotFound` \_ -> Just <$> createRequestItem cd msg (Nothing, Just prevSharedMsgId) -> Nothing <$ delete prevSharedMsgId _ -> pure Nothing -- ##### Group link join requests (don't create contact requests) ##### Just gli@GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do -- TODO [short links] deduplicate request by xContactId? gInfo <- withStore $ \db -> getGroupInfo db vr user groupId if useRelays' gInfo then messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): ignored direct join request from " <> displayName <> " (group uses relays)" else do acceptMember_ <- asks $ acceptMember . chatHooks . config maybe (pure $ Right (GAAccepted, gLinkMemRole)) (\am -> liftIO $ am gInfo gli p) acceptMember_ >>= \case Right (acceptance, useRole) | v < groupFastLinkJoinVersion -> messageError "processContactConnMessage: chat version range incompatible for accepting group join request" | otherwise -> do let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p xContactId_ Nothing welcomeMsgId_ acceptance useRole profileMode Nothing (gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem' Left rjctReason | v < groupJoinRejectVersion -> messageWarning $ "processContactConnMessage (group " <> groupName' gInfo <> "): joining of " <> displayName <> " is blocked" | otherwise -> do mem <- acceptGroupJoinSendRejectAsync user uclId gInfo invId chatVRange p xContactId_ rjctReason toViewTE $ TERejectingGroupJoinRequestMember user gInfo mem rjctReason xGrpRelayInv :: InvitationId -> VersionRangeChat -> GroupRelayInvitation -> CM () xGrpRelayInv invId chatVRange groupRelayInv = do (_gInfo, _ownerMember) <- withStore $ \db -> createRelayRequestGroup db vr user groupRelayInv invId chatVRange lift $ void $ getRelayRequestWorker True -- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays -- TODO [relays] relay: TBC communicate rejection when memberId already exists (currently checked in createJoiningMember) memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Profile -> MemberId -> MemberKey -> CM () memberJoinRequestViaRelay invId chatVRange p joiningMemberId joiningMemberKey = do (_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId case gLinkInfo_ of Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do gInfo <- withStore $ \db -> getGroupInfo db vr user groupId mem <- acceptGroupJoinRequestAsync user uclId gInfo invId chatVRange p Nothing (Just joiningMemberId) Nothing GAAccepted gLinkMemRole Nothing (Just joiningMemberKey) (gInfo', mem', scopeInfo) <- mkGroupChatScope gInfo mem createInternalChatItem user (CDGroupRcv gInfo' scopeInfo mem') (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing toView $ CEvtAcceptingGroupJoinRequestMember user gInfo' mem' Nothing -> messageError "memberJoinRequestViaRelay: no group link info for relay link" muteEventInChannel :: GroupInfo -> GroupMember -> Bool muteEventInChannel gInfo@GroupInfo {membership} m = useRelays' gInfo && memberRole' membership < GRModerator && not (isRelay membership) && memberRole' m < GRModerator memberCanSend :: Maybe GroupMember -> Maybe MsgScope -> CM (Maybe DeliveryTaskContext) -> CM (Maybe DeliveryTaskContext) memberCanSend Nothing _ a = a -- channel message - was previously checked and allowed by relay memberCanSend (Just m@GroupMember {memberRole}) msgScope a = case msgScope of Just MSMember {} -> a Nothing | memberRole > GRObserver || memberPending m -> a | otherwise -> messageError "member is not allowed to send messages" $> Nothing 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 $ CEvtContactDisabled user ct {activeConn = Just ctConn {authErrCounter = authErrCounter'}} _ -> toView $ CEvtConnectionDisabled connEntity SMP _ SMP.QUOTA -> unless (connInactive conn) $ do withStore' $ \db -> setQuotaErrCounter db user conn quotaErrSetOnMERR toView $ CEvtConnectionInactive 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 (CEvtConnectionInactive connEntity True) _ -> pure () continueSending :: ConnectionEntity -> Connection -> CM Bool continueSending connEntity conn = if connInactive conn then do withStore' $ \db -> setQuotaErrCounter db user conn 0 toView $ CEvtConnectionInactive 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, False) withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe (TVar [Text]) -> (Text -> CM (Bool, ShouldDeleteGroupConns)) -> 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 tryAllErrors (action eInfo) >>= \case Right (withRcpt, shouldDelConns) -> unless shouldDelConns $ 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) (AgentConnId "") 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 throwChatError $ CEFileRcvChunk err memberConnectedChatItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM () memberConnectedChatItem gInfo scopeInfo m = -- ts should be broker ts but we don't have it for CON createInternalChatItem user (CDGroupRcv gInfo scopeInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM () notifyMemberConnected gInfo m ct_ = do (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m memberConnectedChatItem gInfo' scopeInfo m' toView $ CEvtConnectedToGroupMember user gInfo' m' ct_ probeMatchingMembers :: Contact -> IncognitoEnabled -> CM () probeMatchingMembers ct connectedIncognito = 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 ms <- map COMGroupMember <$> withStore' (\db -> getMatchingMembers db vr user ct) sendProbeHashes 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 `catchAllErrors` \_ -> 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 . CEvtMessageError user "warning" messageError :: Text -> CM () messageError = toView . CEvtMessageError user "error" newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM () newContentMessage ct mc msg@RcvMessage {sharedMsgId_} msgMeta = do 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, cInfo) <- 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 $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo 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) $ receiveFileEvt' user ft False Nothing Nothing >>= toView messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM () messageFileDescription Contact {contactId} sharedMsgId fileDescr = do (fileId, aci) <- withStore $ \db -> do fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId aci <- getChatItemByFileId db vr user fileId pure (fileId, aci) processFDMessage fileId aci fileDescr groupMessageFileDescription :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> FileDescr -> CM (Maybe DeliveryTaskContext) groupMessageFileDescription g@GroupInfo {groupId} m_ sharedMsgId fileDescr = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId aci <- getChatItemByFileId db vr user fileId pure (fileId, aci) case aci of AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir} | validSender m_ chatDir -> do -- in processFDMessage some paths are programmed as errors, -- for example failure on not approved relays (CEFileNotApproved). -- we catch error, so that even if processFDMessage fails, message can still be forwarded. processFDMessage fileId aci fileDescr `catchAllErrors` \_ -> pure () pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) | otherwise -> messageError "x.msg.file.descr: file/sender mismatch" $> Nothing _ -> messageError "x.msg.file.descr: invalid file description part" $> Nothing processFDMessage :: FileTransferId -> AChatItem -> FileDescr -> CM () processFDMessage fileId aci 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 $ toView $ CEvtRcvFileDescrReady user aci 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, cInfo) <- 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 $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv cInfo 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 $ CEvtChatItemUpdated user (AChatItem SCTDirect SMDRcv (DirectChat ct) ci') startUpdatedTimedItemThread user (ChatRef CTDirect contactId Nothing) ci ci' else toView $ CEvtChatItemNotChanged 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 . CEvtChatItemDeletedNotFound 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 -> do deletions <- if featureAllowed SCFFullDelete forContact ct then deleteDirectCIs user ct [cci] else markDirectCIsDeleted user ct [cci] brokerTs toView $ CEvtChatItemsDeleted user deletions False False | 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 cEvt_ <- 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 $ CEvtChatItemReaction user add r else pure Nothing mapM_ toView cEvt_ groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext) groupMsgReaction g m sharedMsgId itemMemberId scope_ reaction add RcvMessage {msgId} brokerTs | groupFeatureAllowed SGFReactions g = do rs <- withStore' $ \db -> getGroupReactions db g m itemMemberId sharedMsgId False if reactionAllowed add reaction rs then updateChatItemReaction `catchCINotFound` \_ -> case scope_ of Just (MSMember scopeMemberId) | memberRole' m >= GRModerator || scopeMemberId == memberId' m -> do djScope <- withStore $ \db -> do liftIO $ setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs Just . DJSMemberSupport <$> getScopeMemberIdViaMemberId db user g m scopeMemberId pure $ fmap (\js -> DeliveryTaskContext js False) djScope | otherwise -> pure Nothing Nothing -> do withStore' $ \db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs pure $ Just $ DeliveryTaskContext (DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}) False else pure Nothing | otherwise = pure Nothing where updateChatItemReaction = do (CChatItem md ci, scopeInfo) <- withStore $ \db -> do cci <- case itemMemberId of Just itemMemberId' -> getGroupMemberCIBySharedMsgId db user g itemMemberId' sharedMsgId Nothing -> getGroupChatItemBySharedMsgId db user g Nothing sharedMsgId scopeInfo <- getGroupChatScopeInfoForItem db vr user g (cChatItemId cci) pure (cci, scopeInfo) if ciReactionAllowed ci then do reactions <- withStore' $ \db -> do setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs getGroupCIReactions db g itemMemberId sharedMsgId let ci' = CChatItem md ci {reactions} r = ACIReaction SCTGroup SMDRcv (GroupChat g scopeInfo) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction toView $ CEvtChatItemReaction user add r pure $ Just $ infoToDeliveryContext g scopeInfo False else pure Nothing 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 `catchAllErrors` \case ChatErrorStore (SEChatItemSharedMsgIdNotFound sharedMsgId) -> handle sharedMsgId e -> throwError e validSender :: Maybe GroupMember -> CIDirection 'CTGroup 'MDRcv -> Bool validSender (Just m) (CIGroupRcv mem) = sameMemberId (memberId' m) mem validSender m_ CIChannelRcv = maybe True (\m -> memberRole' m == GROwner) m_ validSender _ _ = False isChannelDir :: CIDirection 'CTGroup 'MDRcv -> ShowGroupAsSender isChannelDir CIChannelRcv = True isChannelDir _ = False newGroupContentMessage :: GroupInfo -> Maybe GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryTaskContext) newGroupContentMessage gInfo m_ mc msg@RcvMessage {sharedMsgId_} brokerTs forwarded = case m_ of Nothing -> do createContentItem gInfo Nothing Nothing -- no delivery task - message already forwarded by relay pure Nothing Just m@GroupMember {memberId} -> do (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m content msgScope_ if blockedByAdmin m' then createBlockedByAdmin gInfo' (Just m') scopeInfo $> Nothing else case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of Just f -> rejected gInfo' (Just m') scopeInfo f $> Nothing Nothing -> withStore' (\db -> getCIModeration db vr user gInfo' memberId sharedMsgId_) >>= \case Just ciModeration -> do applyModeration gInfo' m' scopeInfo ciModeration withStore' $ \db -> deleteCIModeration db gInfo' memberId sharedMsgId_ pure Nothing Nothing -> do createContentItem gInfo' (Just m') scopeInfo pure $ Just $ infoToDeliveryContext gInfo' scopeInfo sentAsGroup where rejected gInfo' m' scopeInfo f = newChatItem gInfo' m' scopeInfo (ciContentNoParse $ CIRcvGroupFeatureRejected f) Nothing Nothing False timed_ gInfo' = if forwarded then rcvCITimed_ (Just Nothing) itemTTL else rcvGroupCITimed gInfo' itemTTL live' = fromMaybe False live_ ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ asGroup_ = mcExtMsgContent mc sentAsGroup = asGroup_ == Just True ts@(_, ft_) = msgContentTexts content -- m' is Maybe GroupMember saveRcvCI gInfo' m' scopeInfo = let itemMember_ = if sentAsGroup then Nothing else m' chatDir = maybe (CDChannelRcv gInfo' scopeInfo) (CDGroupRcv gInfo' scopeInfo) itemMember_ in saveRcvChatItem' user chatDir msg sharedMsgId_ brokerTs createBlockedByAdmin gInfo' m' scopeInfo | groupFeatureAllowed SGFFullDelete gInfo' = do -- ignores member role when blocked by admin (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo (ciContentNoParse CIRcvBlocked) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs groupMsgToView cInfo ci' | otherwise = do file_ <- processFileInv gInfo' m' (ci, cInfo) <- createNonLive gInfo' m' scopeInfo file_ ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo' ci groupMsgToView cInfo ci' applyModeration gInfo' m'@GroupMember {memberRole} scopeInfo CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} | moderatorRole < GRModerator || moderatorRole < memberRole = createContentItem gInfo' (Just m') scopeInfo | groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do (ci, cInfo) <- saveRcvCI gInfo' (Just m') scopeInfo (ciContentNoParse CIRcvModerated) Nothing (timed_ gInfo') False M.empty ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt groupMsgToView cInfo ci' | otherwise = do file_ <- processFileInv gInfo' (Just m') (ci, _cInfo) <- createNonLive gInfo' (Just m') scopeInfo file_ deletions <- markGroupCIsDeleted user gInfo' scopeInfo [CChatItem SMDRcv ci] (Just moderator) moderatedAt toView $ CEvtChatItemsDeleted user deletions False False -- m' is Maybe GroupMember createNonLive gInfo' m' scopeInfo file_ = do saveRcvCI gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') False mentions createContentItem gInfo' m' scopeInfo = do file_ <- processFileInv gInfo' m' newChatItem gInfo' m' scopeInfo (CIRcvMsgContent content, ts) (snd <$> file_) (timed_ gInfo') live' unless (maybe False memberBlocked m') $ autoAcceptFile file_ processFileInv gInfo' m' = let fileMember_ = if sentAsGroup then Nothing else m' in processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId gInfo' fileMember_ newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed live = do let mentions' = if maybe False memberBlocked m' then [] else mentions (ci, cInfo) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed live mentions' ci' <- maybe (pure ci) (\m -> blockedMemberCI gInfo' m ci) m' let memberId_ = memberId' <$> m' reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo' memberId_ sharedMsgId) sharedMsgId_ groupMsgToView cInfo ci' {reactions} groupMessageUpdate :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> Maybe Bool -> CM (Maybe DeliveryTaskContext) groupMessageUpdate gInfo@GroupInfo {groupId} m_ sharedMsgId mc mentions msgScope_ msg@RcvMessage {msgId} brokerTs ttl_ live_ asGroup_ | Just m <- m_, prohibitedSimplexLinks gInfo m ft_ = messageWarning ("x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks) $> Nothing | 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_ showGroupAsSender = fromMaybe (isNothing m_) asGroup_ if showGroupAsSender && maybe False (\m -> memberRole' m < GROwner) m_ then messageError "x.msg.update: member attempted to update as group" $> Nothing else do (gInfo', chatDir, mentions', scopeInfo) <- if showGroupAsSender then pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) else case m_ of Just m -> do let mentions' = if memberBlocked m then [] else mentions (gInfo', m', scopeInfo) <- mkGetMessageChatScope vr user gInfo m mc msgScope_ pure (gInfo', CDGroupRcv gInfo' scopeInfo m', mentions', scopeInfo) Nothing -> pure (gInfo, CDChannelRcv gInfo Nothing, mentions, Nothing) (ci, cInfo) <- saveRcvChatItem' user chatDir msg (Just sharedMsgId) brokerTs (content, ts) Nothing timed_ live mentions' ci' <- withStore' $ \db -> do createChatItemVersion db (chatItemId' ci) brokerTs mc updateGroupChatItem db user groupId ci content True live Nothing ci'' <- case chatDir of CDGroupRcv gi' _ m' -> blockedMemberCI gi' m' ci' CDChannelRcv {} -> pure ci' toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv cInfo ci'') pure $ Just $ infoToDeliveryContext gInfo' scopeInfo showGroupAsSender where content = CIRcvMsgContent mc ts@(_, ft_) = msgContentTexts mc live = fromMaybe False live_ updateRcvChatItem = do (cci, scopeInfo) <- withStore $ \db -> do cci <- if asGroup_ == Just True then getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId else case m_ of Just m -> getGroupMemberCIBySharedMsgId db user gInfo (memberId' m) sharedMsgId Nothing -> getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId (cci,) <$> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) case cci of CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} | isSender m' -> updateCI False ci scopeInfo oldMC itemLive (Just $ memberId' m') | otherwise -> messageError "x.msg.update: group member attempted to update a message of another member" $> Nothing CChatItem SMDRcv ci@ChatItem {chatDir = CIChannelRcv, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} | maybe True (\m -> memberRole' m == GROwner) m_ -> updateCI True ci scopeInfo oldMC itemLive Nothing | otherwise -> messageError "x.msg.update: member attempted to update channel message" $> Nothing _ -> messageError "x.msg.update: invalid message update" $> Nothing where isSender m' = maybe False (\m -> sameMemberId (memberId' m) m') m_ updateCI :: ShowGroupAsSender -> ChatItem 'CTGroup 'MDRcv -> Maybe GroupChatScopeInfo -> MsgContent -> Maybe Bool -> Maybe MemberId -> CM (Maybe DeliveryTaskContext) updateCI showGroupAsSender ci scopeInfo oldMC itemLive memberId = 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 ciMentions <- getRcvCIMentions db user gInfo ft_ mentions ci' <- updateGroupChatItem db user groupId ci {reactions} content edited live $ Just msgId updateGroupCIMentions db gInfo ci' ciMentions toView $ CEvtChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci') startUpdatedTimedItemThread user (ChatRef CTGroup groupId $ toChatScope <$> scopeInfo) ci ci' pure $ Just $ infoToDeliveryContext gInfo scopeInfo showGroupAsSender else do toView $ CEvtChatItemNotChanged user (AChatItem SCTGroup SMDRcv (GroupChat gInfo scopeInfo) ci) pure Nothing groupMessageDelete :: GroupInfo -> Maybe GroupMember -> SharedMsgId -> Maybe MemberId -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryTaskContext) groupMessageDelete gInfo@GroupInfo {membership} m_ sharedMsgId sndMemberId_ scope_ rcvMsg brokerTs = findItem >>= \case Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case (chatDir, m_) of (CIGroupRcv mem, Just m@GroupMember {memberId}) -> let msgMemberId = fromMaybe memberId sndMemberId_ in case sndMemberId_ of -- regular deletion Nothing | sameMemberId memberId mem && rcvItemDeletable ci brokerTs -> delete cci False Nothing | otherwise -> messageError "x.msg.del: member attempted invalid message delete" $> Nothing -- moderation (not limited by time) Just _ | sameMemberId memberId mem && msgMemberId == memberId -> delete cci False (Just m) | otherwise -> moderate m mem cci (CIChannelRcv, _) | isNothing sndMemberId_ && isOwner -> delete cci True Nothing | otherwise -> messageError "x.msg.del: invalid channel message delete" $> Nothing (CIGroupSnd, Just m) -> moderate m membership cci _ -> messageError "x.msg.del: invalid message deletion" $> Nothing Left e -> case m_ of Just m@GroupMember {memberId, memberRole = senderRole} -> do let msgMemberId = fromMaybe memberId sndMemberId_ if | msgMemberId == memberId -> messageError ("x.msg.del: message not found, " <> tshow e) $> Nothing | senderRole < GRModerator -> do messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e pure Nothing | otherwise -> case scope_ of Just (MSMember scopeMemberId) -> withStore $ \db -> do liftIO $ createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs supportGMId <- getScopeMemberIdViaMemberId db user gInfo m scopeMemberId pure $ Just $ DeliveryTaskContext {jobScope = DJSMemberSupport supportGMId, sentAsGroup = False} Nothing -> do withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs pure $ Just $ DeliveryTaskContext {jobScope = DJSGroup {jobSpec = DJDeliveryJob {includePending = False}}, sentAsGroup = False} Nothing -> messageError ("x.msg.del: channel message not found, " <> tshow e) $> Nothing where isOwner = maybe True (\m -> memberRole' m == GROwner) m_ RcvMessage {msgId} = rcvMsg findItem = do let tryMemberLookup mId = withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo mId sharedMsgId) tryChannelLookup = withStore' (\db -> runExceptT $ getGroupChatItemBySharedMsgId db user gInfo Nothing sharedMsgId) case sndMemberId_ of Just sId -> tryMemberLookup sId Nothing -> case m_ of Just GroupMember {memberId} -> tryMemberLookup memberId >>= \case Right cci -> pure (Right cci) Left e -> tryChannelLookup >>= \case Right cci -> pure (Right cci) Left _ -> pure (Left e) Nothing -> tryChannelLookup moderate :: GroupMember -> GroupMember -> CChatItem 'CTGroup -> CM (Maybe DeliveryTaskContext) moderate sender mem cci = case sndMemberId_ of Just sndMemberId | sameMemberId sndMemberId mem -> checkRole (memberRole' sender) mem $ do ctx_ <- delete cci False (Just sender) archiveMessageReports cci sender pure ctx_ | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" $> Nothing _ -> messageError "x.msg.del: message of another member without memberId" $> Nothing checkRole senderRole GroupMember {memberRole} a | senderRole < GRModerator || senderRole < memberRole = messageError "x.msg.del: message of another member with insufficient member permissions" $> Nothing | otherwise = a delete :: CChatItem 'CTGroup -> Bool -> Maybe GroupMember -> CM (Maybe DeliveryTaskContext) delete cci asGroup byGroupMember = do scopeInfo <- withStore $ \db -> getGroupChatScopeInfoForItem db vr user gInfo (cChatItemId cci) let fullDelete | asGroup = groupFeatureAllowed SGFFullDelete gInfo | otherwise = maybe False (\m -> groupFeatureMemberAllowed SGFFullDelete m gInfo) m_ deletions <- if fullDelete then deleteGroupCIs user gInfo scopeInfo [cci] byGroupMember brokerTs else markGroupCIsDeleted user gInfo scopeInfo [cci] byGroupMember brokerTs toView $ CEvtChatItemsDeleted user deletions False False pure $ if isNothing m_ then Nothing else Just $ infoToDeliveryContext gInfo scopeInfo asGroup archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM () archiveMessageReports (CChatItem _ ci) byMember = do ciIds <- withStore' $ \db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs unless (null ciIds) $ toView $ CEvtGroupChatItemsDeleted 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, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo 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 gInfo (Just 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, cInfo) <- saveRcvChatItem' user (CDGroupRcv gInfo Nothing m) msg sharedMsgId_ brokerTs content ciFile Nothing False M.empty ci' <- blockedMemberCI gInfo m ci groupMsgToView cInfo ci' blockedMemberCI :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> CM (ChatItem 'CTGroup 'MDRcv) blockedMemberCI gInfo m ci | blockedByAdmin m = withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci | not (showMessages $ memberSettings m) = withStore' $ \db -> markGroupChatItemBlocked db user gInfo ci | otherwise = pure ci 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, ft) <- withStore $ \db -> do fileId <- getFileIdBySharedMsgId db userId contactId sharedMsgId (fileId,) <$> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft ci <- withStore $ \db -> getChatItemByFileId db vr user fileId toView $ CEvtRcvFileSndCancelled user ci ft xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () xFileAcptInv ct sharedMsgId fileConnReq_ fName = do (fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do fileId <- getDirectFileIdBySharedMsgId db user ct sharedMsgId (fileId,) <$> 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 inline Nothing -> do event <- withStore $ \db -> do ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1 sft <- createSndDirectInlineFT db ct ft pure $ CEvtSndFileStart 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") Just _fileConnReq -> messageError "x.file.acpt.inv: receiving file via a separate connection is deprecated" 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 updateDirectCIFileStatus db vr user fileId CIFSSndComplete case file of Just CIFile {fileProtocol = FPXFTP} -> do ft <- withStore $ \db -> getFileTransferMeta db user fileId toView $ CEvtSndFileCompleteXFTP user ci ft _ -> toView $ CEvtSndFileComplete 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 -> Maybe GroupMember -> SharedMsgId -> CM (Maybe DeliveryTaskContext) xFileCancelGroup g@GroupInfo {groupId} m_ sharedMsgId = do (fileId, aci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId (fileId,) <$> getChatItemByFileId db vr user fileId case aci of AChatItem SCTGroup SMDRcv (GroupChat _g scopeInfo) ChatItem {chatDir} | validSender m_ chatDir -> do ft <- withStore $ \db -> getRcvFileTransfer db user fileId unless (rcvFileCompleteOrCancelled ft) $ do cancelRcvFileTransfer user ft toView $ CEvtRcvFileSndCancelled user aci ft pure $ Just $ infoToDeliveryContext g scopeInfo (isChannelDir chatDir) | otherwise -> messageError "x.file.cancel: file cancel sender mismatch" $> Nothing _ -> messageError "x.file.cancel: group member attempted invalid file cancel" $> Nothing xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM () xFileAcptInvGroup GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName = do (fileId, AChatItem _ _ _ ci) <- withStore $ \db -> do fileId <- getGroupFileIdBySharedMsgId db userId groupId sharedMsgId (fileId,) <$> 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 (Nothing, 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 $ CEvtSndFileStart 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") (Just _fileConnReq, _) -> messageError "x.file.acpt.inv: receiving file via a separate connection is deprecated" _ -> 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 => ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM () groupMsgToView cInfo ci = do toView $ CEvtNewChatItems user [AChatItem SCTGroup (msgDirection @d) cInfo 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 void $ createChatItem user (CDGroupSnd gInfo Nothing) False CIChatBanner Nothing (Just epochStart) let GroupMember {groupMemberId, memberId = membershipMemId} = membership if sameGroupLinkId groupLinkId groupLinkId' then do subMode <- chatReadVar subscriptionMode dm <- encodeConnInfo $ XGrpAcpt membershipMemId connIds <- joinAgentConnectionAsync user Nothing True connRequest dm subMode withStore' $ \db -> do setViaGroupLinkUri db groupId connId createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode updateGroupMemberStatusById db userId hostId GSMemAccepted updateGroupMemberStatus db userId membership GSMemAccepted toView $ CEvtUserAcceptedGroupSent user gInfo {membership = membership {memberStatus = GSMemAccepted}} (Just ct) else do let content = CIRcvGroupInvitation (CIGroupInvitation {groupId, groupMemberId, localDisplayName, groupProfile, status = CIGISPending}) memRole (ci, cInfo) <- saveRcvChatItemNoParse user (CDDirectRcv ct) msg brokerTs content withStore' $ \db -> setGroupInvitationChatItemId db user groupId (chatItemId' ci) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci] toView $ CEvtReceivedGroupInvitation {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', contactConns) <- withStore' $ \db -> do ct' <- updateContactStatus db user c CSDeleted (ct',) <$> getContactConnections db vr userId ct' deleteAgentConnectionsAsync $ 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, cInfo) <- saveRcvChatItemNoParse user (CDDirectRcv ct'') msg brokerTs (CIRcvDirectEvent RDEContactDeleted) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci] toView $ CEvtContactDeletedByContact user ct'' else do contactConns <- withStore' $ \db -> getContactConnections db vr userId c deleteAgentConnectionsAsync $ 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 $ CEvtContactUpdated 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 || sd /= sd' || i' /= i || cl' /= cl Profile {displayName = n, fullName = fn, shortDescr = sd, image = i, contactLink = cl} = p Profile {displayName = n', fullName = fn', shortDescr = sd', image = i', contactLink = cl'} = p' xInfoMember :: GroupInfo -> GroupMember -> Profile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xInfoMember gInfo m p' msg brokerTs = do void $ processMemberProfileUpdate gInfo m p' (Just (msg, brokerTs)) pure $ memberEventDeliveryScope m xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> Maybe MemberKey -> CM () xGrpLinkMem gInfo@GroupInfo {membership, businessChat} m@GroupMember {groupMemberId, memberCategory} Connection {viaGroupLink} p' memberKey_ = 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' Nothing withStore' $ \db -> setXGrpLinkMemReceived db groupMemberId True memberKey_ let connectedIncognito = memberIncognito membership probeMatchingMemberContact m' connectedIncognito else messageError "x.grp.link.mem error: invalid group link host profile update" xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM () xGrpLinkAcpt gInfo@GroupInfo {membership} m acceptance role memberId msg brokerTs | sameMemberId memberId membership = processUserAccepted | otherwise = withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId) >>= \case Left _ -> messageError "x.grp.link.acpt error: referenced member does not exist" Right referencedMember -> do (referencedMember', gInfo') <- withStore' $ \db -> do referencedMember' <- updateGroupMemberAccepted db user referencedMember (newMemberStatus referencedMember) role gInfo' <- updateGroupMembersRequireAttention db user gInfo referencedMember referencedMember' pure (referencedMember', gInfo') when (memberCategory referencedMember == GCInviteeMember) $ introduceToRemainingMembers referencedMember' -- create item in both scopes memberConnectedChatItem gInfo' Nothing referencedMember' let scopeInfo = Just $ GCSIMemberSupport {groupMember_ = Just referencedMember'} gEvent = RGEMemberAccepted (groupMemberId' referencedMember') (fromLocalProfile $ memberProfile referencedMember') (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m) msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci toView $ CEvtMemberAcceptedByOther user gInfo' m referencedMember' where newMemberStatus refMem = case memberConn refMem of Just c | connReady c -> GSMemConnected _ -> GSMemAnnounced where processUserAccepted = case acceptance of GAAccepted -> do membership' <- withStore' $ \db -> updateGroupMemberAccepted db user membership GSMemConnected role -- create item in both scopes let gInfo' = gInfo {membership = membership'} cd = CDGroupRcv gInfo' Nothing m createInternalChatItem user cd (CIRcvGroupE2EEInfo E2EInfo {pqEnabled = Just PQEncOff}) Nothing let prepared = preparedGroup gInfo' unless (isJust prepared) $ createGroupFeatureItems user cd CIRcvGroupFeature gInfo' let welcomeMsgId_ = (\PreparedGroup {welcomeSharedMsgId = mId} -> mId) <$> preparedGroup gInfo' unless (isJust welcomeMsgId_) $ maybeCreateGroupDescrLocal gInfo' m createInternalChatItem user cd (CIRcvGroupEvent RGEUserAccepted) Nothing let scopeInfo = Just $ GCSIMemberSupport {groupMember_ = Nothing} createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m) (CIRcvGroupEvent RGEUserAccepted) Nothing toView $ CEvtUserJoinedGroup user gInfo' m GAPendingReview -> do membership' <- withStore' $ \db -> updateGroupMemberAccepted db user membership GSMemPendingReview role let gInfo' = gInfo {membership = membership'} scopeInfo = Just $ GCSIMemberSupport {groupMember_ = Nothing} createInternalChatItem user (CDGroupSnd gInfo' scopeInfo) (CISndGroupEvent SGEUserPendingReview) Nothing toView $ CEvtMemberAcceptedByOther user gInfo' m membership' GAPendingApproval -> messageWarning "x.grp.link.acpt: unexpected group acceptance - pending approval" introduceToRemainingMembers acceptedMember = do introduceToRemaining vr user gInfo acceptedMember when (groupFeatureAllowed SGFHistory gInfo) $ sendHistory user gInfo acceptedMember maybeCreateGroupDescrLocal :: GroupInfo -> GroupMember -> CM () maybeCreateGroupDescrLocal gInfo@GroupInfo {groupProfile = GroupProfile {description}} m = unless expectHistory $ forM_ description $ \descr -> createInternalChatItem user (CDGroupRcv gInfo Nothing m) (CIRcvMsgContent $ MCText descr) Nothing where expectHistory = groupFeatureAllowed SGFHistory gInfo && m `supportsVersion` groupHistoryIncludeWelcomeVersion processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Maybe (RcvMessage, UTCTime) -> CM GroupMember processMemberProfileUpdate gInfo m@GroupMember {memberProfile = p, memberContactId} p' msgTs_ | redactedMemberProfile allowSimplexLinks (fromLocalProfile p) /= redactedMemberProfile allowSimplexLinks p' = do updateBusinessChatProfile gInfo case memberContactId of Nothing -> do m' <- withStore $ \db -> updateMemberProfile db user m p' unless (muteEventInChannel gInfo m') $ do forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated 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' unless (muteEventInChannel gInfo m') $ do forM_ msgTs_ $ createProfileUpdatedItem m' toView $ CEvtGroupMemberUpdated user gInfo m m' toView $ CEvtContactUpdated 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 allowSimplexLinks = groupFeatureMemberAllowed SGFSimplexLinks m gInfo updateBusinessChatProfile g@GroupInfo {businessChat} = case businessChat of Just bc | isMainBusinessMember bc m -> do g' <- withStore $ \db -> updateGroupProfileFromMember db user g p' toView $ CEvtGroupUpdated user g g' (Just m) Nothing _ -> pure () isMainBusinessMember BusinessChatInfo {chatType, businessId, customerId} GroupMember {memberId} = case chatType of BCBusiness -> businessId == memberId BCCustomer -> customerId == memberId createProfileUpdatedItem m' (msg, brokerTs) = do (gInfo', m'', scopeInfo) <- mkGroupChatScope gInfo m' let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated (fromLocalProfile p) p' cd = CDGroupRcv gInfo' scopeInfo m'' (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs ciContent groupMsgToView cInfo ci 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 `catchAllErrors` \_ -> 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 {profile = p1} -> case cgm2 of 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 COMContact _ -> messageWarning "probeMatch ignored: contacts are not merged" >> pure Nothing COMGroupMember m1@GroupMember {groupId, memberProfile = p1, memberContactId} -> case cgm2 of COMContact c2@Contact {profile = p2} | memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> case memberConn m1 of Just conn -> do void $ sendDirectMemberMessage conn (XInfoProbeOk probe) groupId COMContact <$$> associateMemberAndContact c2 m1 _ -> messageWarning "probeMatch ignored: matched member doesn't have connection" >> pure Nothing | 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 -> case cgm2 of Just (COMGroupMember m2@GroupMember {memberContactId}) | isNothing memberContactId -> void $ associateMemberAndContact c1 m2 | otherwise -> messageWarning "xInfoProbeOk ignored: member already has contact" Just (COMContact _) -> messageWarning "xInfoProbeOk ignored: contacts are not merged" _ -> 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, cInfo) <- 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 $ CEvtCallInvitation RcvCallInvitation {user, contact = ct, callType, sharedKey, callUUID, callTs = chatItemTs' ci} toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo 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, cInfo) <- saveRcvChatItem' user (CDDirectRcv ct) msg sharedMsgId_ brokerTs content Nothing Nothing False M.empty toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo 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 CEvtCallOffer {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 $ CEvtCallAnswer 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 $ CEvtCallExtraInfo 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 $ CEvtCallExtraInfo 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 $ CEvtCallEnded 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' Nothing, chatItemId) msgCallStateError :: Text -> Call -> CM () msgCallStateError eventName Call {callState} = messageError $ eventName <> ": wrong call state " <> T.pack (show $ callStateTag callState) 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 g <- withStore $ \db -> do liftIO $ associateMemberWithContactRecord db user c1 m2 getGroupInfo db vr user groupId toView $ CEvtContactAndMemberAssociated user c1 g m2 c1 pure c1 associateContactWithMember :: GroupMember -> Contact -> CM Contact associateContactWithMember m1@GroupMember {groupId} c2 = do (c2', g) <- withStore $ \db -> liftM2 (,) (associateContactWithMemberRecord db vr user m1 c2) (getGroupInfo db vr user groupId) toView $ CEvtContactAndMemberAssociated user c2 g m1 c2' pure c2' saveConnInfo :: Connection -> ConnInfo -> CM (Connection, Maybe GroupInfo) saveConnInfo activeConn connInfo = do ChatMessage {chatVRange, chatMsgEvent} <- parseChatMessage activeConn connInfo conn' <- updatePeerChatVRange activeConn chatVRange case chatMsgEvent of XInfo p -> do ct <- withStore $ \db -> createDirectContact db vr user conn' p toView $ CEvtContactConnecting user ct pure (conn', Nothing) XGrpLinkInv glInv -> do (gInfo, host) <- withStore $ \db -> createGroupInvitedViaLink db vr user conn' glInv toView $ CEvtGroupLinkConnecting user gInfo host pure (conn', Just gInfo) XGrpLinkReject glRjct@GroupLinkRejection {rejectionReason} -> do (gInfo, host) <- withStore $ \db -> createGroupRejectedViaLink db vr user conn' glRjct toView $ CEvtGroupLinkConnecting user gInfo host toViewTE $ TEGroupLinkRejected user gInfo rejectionReason pure (conn', Just gInfo) -- TODO show/log error, other events in SMP confirmation _ -> pure (conn', Nothing) xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpMemNew gInfo m memInfo@(MemberInfo memId memRole _ _ _) msgScope_ msg brokerTs = do unless (useRelays' gInfo && isRelay m) $ checkHostRole m memRole if sameMemberId memId (membership gInfo) then pure Nothing else do withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Right unknownMember@GroupMember {memberStatus = GSMemUnknown} -> do (updatedMember, gInfo') <- withStore $ \db -> do updatedMember <- updateUnknownMemberAnnounced db vr user m unknownMember memInfo initialStatus gInfo' <- if memberPending updatedMember then liftIO $ increaseGroupMembersRequireAttention db user gInfo else pure gInfo pure (updatedMember, gInfo') gInfo'' <- updatePublicGroupData user gInfo' toView $ CEvtUnknownMemberAnnounced user gInfo'' m unknownMember updatedMember memberAnnouncedToView updatedMember gInfo'' pure $ deliveryJobScope updatedMember Right _ | useRelays' gInfo -> logInfo "x.grp.mem.new: member already created via another relay" $> Nothing | otherwise -> messageError "x.grp.mem.new error: member already exists" $> Nothing Left _ -> do (newMember, gInfo') <- withStore $ \db -> do newMember <- createNewGroupMember db user gInfo m memInfo GCPostMember initialStatus gInfo' <- if memberPending newMember then liftIO $ increaseGroupMembersRequireAttention db user gInfo else pure gInfo pure (newMember, gInfo') gInfo'' <- updatePublicGroupData user gInfo' memberAnnouncedToView newMember gInfo'' pure $ deliveryJobScope newMember where initialStatus = case msgScope_ of Just (MSMember _) -> GSMemPendingReview _ -> GSMemAnnounced deliveryJobScope GroupMember {groupMemberId, memberStatus} | memberStatus == GSMemPendingApproval = Nothing | memberStatus == GSMemPendingReview = Just $ DJSMemberSupport groupMemberId | otherwise = Just DJSGroup {jobSpec = DJDeliveryJob {includePending = False}} memberAnnouncedToView announcedMember@GroupMember {groupMemberId, memberProfile} gInfo' = do (announcedMember', scopeInfo) <- getMemNewChatScope announcedMember let event = RGEMemberAdded groupMemberId (fromLocalProfile memberProfile) (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m) msg brokerTs (CIRcvGroupEvent event) groupMsgToView cInfo ci case scopeInfo of Just (GCSIMemberSupport _) -> do createInternalChatItem user (CDGroupRcv gInfo' scopeInfo m) (CIRcvGroupEvent RGENewMemberPendingReview) (Just brokerTs) _ -> pure () toView $ CEvtJoinedGroupMemberConnecting user gInfo' m announcedMember' getMemNewChatScope announcedMember = case msgScope_ of Nothing -> pure (announcedMember, Nothing) Just (MSMember _) -> do (announcedMember', scopeInfo) <- mkMemberSupportChatInfo announcedMember pure (announcedMember', Just scopeInfo) 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 existingMember | useRelays' gInfo -> void $ withStore $ \db -> updatePreparedChannelMember db vr user existingMember memInfo | otherwise -> messageError "x.grp.mem.intro ignored: member already exists" Left _ | useRelays' gInfo -> void $ withStore $ \db -> createIntroReMember db user gInfo memInfo memRestrictions | otherwise -> do when (memberRole < GRAdmin) $ throwChatError (CEGroupContactRole c) case memChatVRange of Nothing -> messageError "x.grp.mem.intro: member chat version range incompatible" Just (ChatVersionRange mcvr) | maxVersion mcvr >= groupDirectInvVersion -> do 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 let chatV = maybe (minVersion vr) (\peerVR -> vr `peerConnChatVersion` fromChatVRange peerVR) memChatVRange void $ withStore $ \db -> do reMember <- createIntroReMember db user gInfo memInfo memRestrictions createIntroReMemberConn db user m reMember chatV memInfo groupConnIds subMode | otherwise -> messageError "x.grp.mem.intro: member chat version range incompatible" _ -> 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 -> sendGroupMemberMessage gInfo reMember $ XGrpMemFwd (memberInfo gInfo m) introInv _ -> 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 _ _) IntroInvitation {groupConnReq, directConnReq} = do let GroupMember {memberId = membershipMemId} = membership checkHostRole m memRole toMember <- withStore $ \db -> do toMember <- getGroupMemberByMemberId db vr user gInfo memId -- 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. `catchError` \case SEGroupMemberNotFoundByMemberId _ -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced e -> throwError e -- TODO [knocking] separate pending statuses from GroupMemberStatus? -- TODO add GSMemIntroInvitedPending, GSMemConnectedPending, etc.? -- TODO keep as is? (GSMemIntroInvited has no purpose) let newMemberStatus = if memberPending toMember then memberStatus toMember else GSMemIntroInvited liftIO $ updateGroupMemberStatus db userId toMember newMemberStatus pure toMember subMode <- chatReadVar subscriptionMode -- [incognito] send membership incognito profile, create direct connection as incognito let membershipProfile = redactedMemberProfile allowSimplexLinks $ fromLocalProfile $ memberProfile membership allowSimplexLinks = groupFeatureUserAllowed SGFSimplexLinks gInfo dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile -- [async agent commands] no continuation needed, but commands should be asynchronous for stability groupConnIds <- joinAgentConnectionAsync user Nothing (chatHasNtfs chatSettings) groupConnReq dm subMode directConnIds <- forM directConnReq $ \dcr -> joinAgentConnectionAsync user Nothing 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 (Maybe DeliveryJobScope) xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg@RcvMessage {msgSigned} 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" $> Nothing 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" $> Nothing | otherwise = do withStore' $ \db -> updateGroupMemberRole db user member memRole (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo' m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci toView CEvtMemberRole {user, groupInfo = gInfo'', byMember = m', member = member {memberRole = memRole}, fromRole, toRole = memRole, msgSigned} pure $ memberEventDeliveryScope member 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 (Maybe DeliveryJobScope) xGrpMemRestrict gInfo@GroupInfo {membership = GroupMember {memberId = membershipMemId}} m@GroupMember {memberRole = senderRole} memId MemberRestrictions {restriction} msg@RcvMessage {msgSigned} brokerTs | membershipMemId == memId = pure Nothing -- ignore - XGrpMemRestrict can be sent to restricted member for efficiency | otherwise = do unknownRole <- unknownMemberRole gInfo withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memId "" unknownRole True) >>= \case Nothing -> messageError "x.grp.mem.restrict: no member" $> Nothing -- shouldn't happen Just (bm, unknown) -> do let GroupMember {groupMemberId = bmId, memberRole, blockedByAdmin, memberProfile = bmp} = bm if | blockedByAdmin == mrsBlocked restriction -> pure Nothing | senderRole < GRModerator || senderRole < memberRole -> messageError "x.grp.mem.restrict with insufficient member permissions" $> Nothing | otherwise -> do bm' <- setMemberBlocked bm toggleNtf bm' (not blocked) let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId (fromLocalProfile bmp) blocked (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo' scopeInfo m') msg brokerTs ciContent when unknown $ toView $ CEvtUnknownMemberBlocked user gInfo m bm' groupMsgToView cInfo ci toView CEvtMemberBlockedForAll {user, groupInfo = gInfo', byMember = m', member = bm', blocked, msgSigned} pure $ memberEventDeliveryScope bm where setMemberBlocked bm = withStore' $ \db -> updateGroupMemberBlocked db user gInfo restriction bm blocked = mrsBlocked restriction xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM () xGrpMemCon gInfo sendingMem memId = do refMem <- withStore $ \db -> getGroupMemberByMemberId db vr user gInfo memId -- Updating vectors in separate transactions to avoid deadlocks. withStore $ \db -> setMemberVectorRelationConnected db sendingMem refMem MRSubjectConnected withStore $ \db -> setMemberVectorRelationConnected db refMem sendingMem MRReferencedConnected xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> VerifiedMsg 'Json -> RcvMessage -> UTCTime -> Bool -> CM (Maybe DeliveryJobScope) xGrpMemDel gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId withMessages verifiedMsg msg@RcvMessage {msgSigned} brokerTs forwarded = do let GroupMember {memberId = membershipMemId} = membership if membershipMemId == memId then checkRole membership $ do deleteGroupLinkIfExists user gInfo -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemRemoved let membership' = membership {memberStatus = GSMemRemoved} when withMessages $ deleteMessages gInfo membership' SMDSnd deleteMemberItem gInfo RGEUserDeleted toView $ CEvtDeletedMemberUser user gInfo {membership = membership'} m withMessages msgSigned pure $ Just DJSGroup {jobSpec = DJRelayRemoved} else withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case Left _ -> do messageError "x.grp.mem.del with unknown member ID" pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} Right deletedMember@GroupMember {groupMemberId, memberProfile, memberStatus} -> checkRole deletedMember $ do -- ? prohibit deleting member if it's the sender - sender should use x.grp.leave let shouldForward = isUserGrpFwdRelay gInfo && not forwarded if shouldForward then do -- Special case: forward before deleting connection. forwardToMember deletedMember deleteMemberConnection' deletedMember True else deleteMemberConnection deletedMember let deliveryScope = memberEventDeliveryScope deletedMember gInfo' <- case deliveryScope of -- Keep member record if it's support scope - it will be required for forwarding inside that scope. Just (DJSMemberSupport _) | shouldForward -> updateMemberRecordDeleted user gInfo deletedMember GSMemRemoved -- Undeleted "member connected" chat item will prevent deletion of member record. _ -> deleteOrUpdateMemberRecord user gInfo deletedMember gInfo'' <- updatePublicGroupData user gInfo' let wasDeleted = memberStatus == GSMemRemoved || memberStatus == GSMemLeft deletedMember' = deletedMember {memberStatus = GSMemRemoved} when withMessages $ deleteMessages gInfo'' deletedMember' SMDRcv unless wasDeleted $ deleteMemberItem gInfo'' $ RGEMemberDeleted groupMemberId (fromLocalProfile memberProfile) toView $ CEvtDeletedMember user gInfo'' m deletedMember' withMessages msgSigned pure deliveryScope where checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = messageError "x.grp.mem.del with insufficient member permissions" $> Nothing | otherwise = a deleteMemberItem gi gEvent = do (gi', m', scopeInfo) <- mkGroupChatScope gi m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gi' scopeInfo m') msg brokerTs (CIRcvGroupEvent gEvent) groupMsgToView cInfo ci deleteMessages :: MsgDirectionI d => GroupInfo -> GroupMember -> SMsgDirection d -> CM () deleteMessages gInfo' delMem msgDir | groupFeatureMemberAllowed SGFFullDelete m gInfo' = deleteGroupMemberCIs user gInfo' delMem m msgDir | otherwise = markGroupMemberCIsDeleted user gInfo' delMem m forwardToMember :: GroupMember -> CM () forwardToMember member = let fwd = GrpMsgForward {fwdSender = FwdMember (memberId' m) (memberShortenedName m), fwdBrokerTs = brokerTs} in sendFwdMemberMessage member fwd verifiedMsg isUserGrpFwdRelay :: GroupInfo -> Bool isUserGrpFwdRelay gInfo@GroupInfo {membership} | useRelays' gInfo = isRelay membership | otherwise = memberRole' membership >= GRAdmin isMemberGrpFwdRelay :: GroupInfo -> GroupMember -> Bool isMemberGrpFwdRelay gInfo m | useRelays' gInfo = isRelay m | otherwise = memberRole' m >= GRAdmin unknownMemberRole :: GroupInfo -> CM GroupMemberRole unknownMemberRole gInfo | useRelays' gInfo = asks $ channelSubscriberRole . config | otherwise = pure GRAuthor xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpLeave gInfo m msg@RcvMessage {msgSigned} brokerTs = do deleteMemberConnection m -- member record is not deleted to allow creation of "member left" chat item gInfo' <- updateMemberRecordDeleted user gInfo m GSMemLeft gInfo'' <- updatePublicGroupData user gInfo' unless (muteEventInChannel gInfo'' m) $ do (gInfo''', m', scopeInfo) <- mkGroupChatScope gInfo'' m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo''' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEMemberLeft) groupMsgToView cInfo ci toView $ CEvtLeftMember user gInfo''' m' {memberStatus = GSMemLeft} msgSigned pure $ memberEventDeliveryScope m xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM () xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg@RcvMessage {msgSigned} brokerTs = do when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner deleteGroupLinkIfExists user gInfo withStore' $ \db -> updateGroupMemberStatus db userId membership GSMemGroupDeleted -- TODO [relays] possible improvement is to immediately delete rcv queues if isUserGrpFwdRelay unless (isUserGrpFwdRelay gInfo) $ deleteGroupConnections user gInfo False (gInfo'', m', scopeInfo) <- mkGroupChatScope gInfo m (ci, cInfo) <- saveRcvChatItemNoParse user (CDGroupRcv gInfo'' scopeInfo m') msg brokerTs (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView cInfo ci toView $ CEvtGroupDeleted user gInfo'' {membership = membership {memberStatus = GSMemGroupDeleted}} m' msgSigned xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM (Maybe DeliveryJobScope) xGrpInfo g@GroupInfo {groupProfile = p@GroupProfile {sharedGroupId = gId}, businessChat} m@GroupMember {memberRole} p'@GroupProfile {sharedGroupId = gId'} msg@RcvMessage {msgSigned} brokerTs | memberRole < GROwner = messageError "x.grp.info with insufficient member permissions" $> Nothing | useRelays' g && gId' /= gId = messageError "x.grp.info: sharedGroupId cannot be changed" $> Nothing | not (useRelays' g) && isJust gId' = messageError "x.grp.info: sharedGroupId not allowed in p2p groups" $> Nothing | otherwise = do case businessChat of Nothing -> unless (p == p') $ do g' <- withStore $ \db -> updateGroupProfile db user g p' (g'', m', scopeInfo) <- mkGroupChatScope g' m toView $ CEvtGroupUpdated user g g'' (Just m') msgSigned let cd = CDGroupRcv g'' scopeInfo m' unless (sameGroupProfileInfo p p') $ do (ci, cInfo) <- saveRcvChatItemNoParse user cd msg brokerTs (CIRcvGroupEvent $ RGEGroupUpdated p') groupMsgToView cInfo ci createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' void $ forkIO $ void $ setGroupLinkData' NRMBackground user g'' Just _ -> updateGroupPrefs_ msgSigned g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p' pure $ Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> RcvMessage -> CM (Maybe DeliveryJobScope) xGrpPrefs g m@GroupMember {memberRole} ps' RcvMessage {msgSigned} | memberRole < GROwner = messageError "x.grp.prefs with insufficient member permissions" $> Nothing | otherwise = updateGroupPrefs_ msgSigned g m ps' $> Just DJSGroup {jobSpec = DJDeliveryJob {includePending = True}} updateGroupPrefs_ :: Maybe MsgSigStatus -> GroupInfo -> GroupMember -> GroupPreferences -> CM () updateGroupPrefs_ msgSigned g@GroupInfo {groupProfile = p} m ps' = unless (groupPreferences p == Just ps') $ do g' <- withStore' $ \db -> updateGroupPreferences db user g ps' toView $ CEvtGroupUpdated user g g' (Just m) msgSigned (g'', m', scopeInfo) <- mkGroupChatScope g' m let cd = CDGroupRcv g'' scopeInfo m' createGroupFeatureChangedItems user cd CIRcvGroupFeature g g'' xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM () xGrpDirectInv g@GroupInfo {groupId, groupProfile = gp} m mConn@Connection {connId = mConnId} connReq mContent_ msg brokerTs | not (groupFeatureMemberAllowed SGFDirectMessages m g) = messageError "x.grp.direct.inv: direct messages not allowed" | memberBlocked m = messageWarning "x.grp.direct.inv: member is blocked (ignoring)" | otherwise = do 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 groupDirectInv = GroupDirectInvitation { groupDirectInvLink = connReq, fromGroupId_ = Just groupId, fromGroupMemberId_ = Just (groupMemberId' m), fromGroupMemberConnId_ = Just mConnId, groupDirectInvStartedConnection = isTrue $ autoAcceptMemberContacts user } joinExistingContact subMode mCt@Contact {contactId = mContactId} | isTrue (autoAcceptMemberContacts user) = do (cmdId, acId) <- joinConn subMode mCt' <- withStore $ \db -> do updateMemberContactInvited db user mCt groupDirectInv void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode getContact db vr user mContactId securityCodeChanged mCt' createItems mCt' m | otherwise = do acId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connReq PQSupportOff mCt' <- withStore $ \db -> do updateMemberContactInvited db user mCt groupDirectInv void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode getContact db vr user mContactId securityCodeChanged mCt' createInternalChatItem user (CDDirectRcv mCt') (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing createItems mCt' m createNewContact subMode | isTrue (autoAcceptMemberContacts user) = do (cmdId, acId) <- joinConn subMode -- [incognito] reuse membership incognito profile (mCt, m') <- withStore $ \db -> do (mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv void $ liftIO $ createMemberContactConn db user acId (Just cmdId) g mConn ConnJoined mContactId subMode mCt <- getContact db vr user mContactId pure (mCt, m') createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart) createItems mCt m' | otherwise = do acId <- withAgent $ \a -> prepareConnectionToJoin a (aUserId user) True connReq PQSupportOff (mCt, m') <- withStore $ \db -> do (mContactId, m') <- liftIO $ createMemberContactInvited db user g m groupDirectInv void $ liftIO $ createMemberContactConn db user acId Nothing g mConn ConnPrepared mContactId subMode mCt <- getContact db vr user mContactId pure (mCt, m') createInternalChatItem user (CDDirectSnd mCt) CIChatBanner (Just epochStart) createInternalChatItem user (CDDirectRcv mCt) (CIRcvDirectEvent $ RDEGroupInvLinkReceived gp) Nothing createItems mCt m' joinConn subMode = do -- [incognito] send membership incognito profile let p = userProfileDirect user (fromLocalProfile <$> incognitoMembershipProfile g) Nothing True -- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ) dm <- encodeConnInfo $ XInfo p joinAgentConnectionAsync user Nothing True connReq dm subMode createItems mCt' m' = do (g', m'', scopeInfo) <- mkGroupChatScope g m' createInternalChatItem user (CDGroupRcv g' scopeInfo m'') (CIRcvGroupEvent RGEMemberCreatedContact) Nothing toView $ CEvtNewMemberContactReceivedInv user mCt' g' m'' forM_ mContent_ $ \mc -> do (ci, cInfo) <- saveRcvChatItem user (CDDirectRcv mCt') msg brokerTs (CIRcvMsgContent mc, msgContentTexts mc) toView $ CEvtNewChatItems user [AChatItem SCTDirect SMDRcv cInfo ci] securityCodeChanged :: Contact -> CM () securityCodeChanged ct = do toViewTE $ TEContactVerificationReset user ct createInternalChatItem user (CDDirectRcv ct) (CIRcvConnEvent RCEVerificationCodeReset) Nothing xGrpMsgForward :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> GrpMsgForward -> ParsedMsg 'Json -> UTCTime -> CM () xGrpMsgForward gInfo scopeInfo m@GroupMember {localDisplayName} GrpMsgForward {fwdSender, fwdBrokerTs = msgTs} parsedMsg@(ParsedMsg _ _ chatMsg@ChatMessage {chatMsgEvent}) brokerTs = do unless (isMemberGrpFwdRelay gInfo m) $ throwChatError (CEGroupContactRole localDisplayName) case fwdSender of FwdMember memberId memberName -> do unknownRole <- unknownMemberRole gInfo let allowCreate = toCMEventTag chatMsgEvent /= XGrpLeave_ withStore (\db -> getCreateUnknownGMByMemberId db vr user gInfo memberId memberName unknownRole allowCreate) >>= \case Just (author, unknown) -> do when unknown $ toView $ CEvtUnknownMemberCreated user gInfo m author void $ withVerifiedMsg gInfo scopeInfo author parsedMsg msgTs $ (`processForwardedMsg` Just author) Nothing -> pure () FwdChannel -> processForwardedMsg (VMUnsigned chatMsg) Nothing where -- ! see isForwardedGroupMsg: forwarded group events should include msgId to be deduplicated processForwardedMsg :: VerifiedMsg 'Json -> Maybe GroupMember -> CM () processForwardedMsg verifiedMsg author_ = do rcvMsg_ <- saveGroupFwdRcvMsg user gInfo m author_ verifiedMsg brokerTs forM_ rcvMsg_ $ \rcvMsg@RcvMessage {chatMsgEvent = ACME _ event} -> case event of XMsgNew mc -> void $ memberCanSend author_ scope $ newGroupContentMessage gInfo author_ mc rcvMsg msgTs True where ExtMsgContent {scope} = mcExtMsgContent mc -- file description is always allowed, to allow sending files to support scope XMsgFileDescr sharedMsgId fileDescr -> void $ groupMessageFileDescription gInfo author_ sharedMsgId fileDescr XMsgUpdate sharedMsgId mContent mentions ttl live msgScope asGroup_ -> void $ memberCanSend author_ msgScope $ groupMessageUpdate gInfo author_ sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live asGroup_ XMsgDel sharedMsgId memId scope_ -> void $ groupMessageDelete gInfo author_ sharedMsgId memId scope_ rcvMsg msgTs XMsgReact sharedMsgId memId scope_ reaction add -> withAuthor XMsgReact_ $ \author -> void $ groupMsgReaction gInfo author sharedMsgId memId scope_ reaction add rcvMsg msgTs XFileCancel sharedMsgId -> void $ xFileCancelGroup gInfo author_ sharedMsgId XInfo p -> withAuthor XInfo_ $ \author -> void $ xInfoMember gInfo author p rcvMsg msgTs XGrpMemNew memInfo msgScope -> withAuthor XGrpMemNew_ $ \author -> void $ xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs XGrpMemRole memId memRole -> withAuthor XGrpMemRole_ $ \author -> void $ xGrpMemRole gInfo author memId memRole rcvMsg msgTs XGrpMemRestrict memId memRestrictions -> withAuthor XGrpMemRestrict_ $ \author -> void $ xGrpMemRestrict gInfo author memId memRestrictions rcvMsg msgTs XGrpMemDel memId withMessages -> withAuthor XGrpMemDel_ $ \author -> void $ xGrpMemDel gInfo author memId withMessages verifiedMsg rcvMsg msgTs True XGrpLeave -> withAuthor XGrpLeave_ $ \author -> void $ xGrpLeave gInfo author rcvMsg msgTs XGrpDel -> withAuthor XGrpDel_ $ \author -> void $ xGrpDel gInfo author rcvMsg msgTs XGrpInfo p' -> withAuthor XGrpInfo_ $ \author -> void $ xGrpInfo gInfo author p' rcvMsg msgTs XGrpPrefs ps' -> withAuthor XGrpPrefs_ $ \author -> void $ xGrpPrefs gInfo author ps' rcvMsg _ -> messageError $ "x.grp.msg.forward: unsupported forwarded event " <> T.pack (show $ toCMEventTag event) where withAuthor :: CMEventTag e -> (GroupMember -> CM ()) -> CM () withAuthor tag action = case author_ of Just author -> action author Nothing -> messageError $ "x.grp.msg.forward: event " <> tshow tag <> " requires author" withVerifiedMsg :: MsgEncodingI e => GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> ParsedMsg e -> UTCTime -> (VerifiedMsg e -> CM a) -> CM (Maybe a) withVerifiedMsg gInfo@GroupInfo {membership} scopeInfo member (ParsedMsg _ signedMsg_ chatMsg@ChatMessage {chatMsgEvent}) ts action = case verified of Just verifiedMsg -> Just <$> action verifiedMsg Nothing -> do createInternalChatItem user (CDGroupRcv gInfo scopeInfo member) (CIRcvGroupEvent RGEMsgBadSignature) (Just ts) pure Nothing where verified = case signedMsg_ of Just sm@SignedMsg {chatBinding, signatures, signedBody} | GroupMember {memberPubKey = Just pubKey, memberId} <- member -> case chatBinding of CBGroup | Just GroupKeys {sharedGroupId} <- groupKeys gInfo -> let prefix = smpEncode chatBinding <> smpEncode (sharedGroupId, memberId) in signed MSSVerified <$ guard (all (\(MsgSignature KRMember sig) -> C.verify (C.APublicVerifyKey C.SEd25519 pubKey) sig (prefix <> signedBody)) signatures) _ -> signed MSSSignedNoKey <$ guard signatureOptional | otherwise -> signed MSSSignedNoKey <$ guard (signatureOptional || unverifiedAllowed membership member tag) where signed status = VMSigned status sm chatMsg Nothing -> VMUnsigned chatMsg <$ guard signatureOptional where tag = toCMEventTag chatMsgEvent signatureOptional = not (useRelays' gInfo) || not (requiresSignature tag) directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM () directMsgReceived ct conn@Connection {connId} msgMeta msgRcpts = do checkIntegrityCreateItem (CDDirectRcv ct) msgMeta `catchAllErrors` \_ -> 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 (gInfo', m', scopeInfo) <- mkGroupChatScope gInfo m checkIntegrityCreateItem (CDGroupRcv gInfo' scopeInfo m') msgMeta `catchAllErrors` \_ -> 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 $ CEvtChatItemsStatusesUpdated 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 $ CEvtChatItemsStatusesUpdated 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 acis <- withStore $ \db -> do items <- liftIO $ getGroupChatItemsByAgentMsgId db user groupId connId msgId cis <- catMaybes <$> mapM (updateItem db) items -- SENT and RCVD events are received for messages that may be batched in single scope, -- so we can look up scope of first item scopeInfo <- case cis of (ci : _) -> getGroupChatScopeInfoForItem db vr user gInfo (chatItemId' ci) _ -> pure Nothing pure $ map (gItem scopeInfo) cis unless (null acis) $ toView $ CEvtChatItemsStatusesUpdated user acis where gItem scopeInfo ci = AChatItem SCTGroup SMDSnd (GroupChat gInfo scopeInfo) ci 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 deleteGroupConnections :: User -> GroupInfo -> Bool -> CM () deleteGroupConnections user gInfo@GroupInfo {membership} waitDelivery = do vr <- chatVersionRange -- member records are not deleted to keep history members <- getMembers vr deleteMembersConnections' user members waitDelivery where getMembers vr | useRelays' gInfo, not (isRelay membership) = withStore' $ \db -> getGroupRelayMembers db vr user gInfo | otherwise = withStore' $ \db -> getGroupMembers db vr user gInfo startDeliveryTaskWorkers :: CM () startDeliveryTaskWorkers = do workerScopes <- withStore' $ \db -> getPendingDeliveryTaskScopes db lift $ forM_ workerScopes resumeDeliveryTaskWork resumeDeliveryTaskWork :: DeliveryWorkerKey -> CM' () resumeDeliveryTaskWork = void . getDeliveryTaskWorker False getDeliveryTaskWorker :: Bool -> DeliveryWorkerKey -> CM' Worker getDeliveryTaskWorker hasWork deliveryKey = do ws <- asks deliveryTaskWorkers a <- asks smpAgent getAgentWorker "delivery_task" hasWork a deliveryKey ws $ runDeliveryTaskWorker a deliveryKey runDeliveryTaskWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM () runDeliveryTaskWorker a deliveryKey Worker {doWork} = do delay <- asks $ deliveryWorkerDelay . config vr <- chatVersionRange -- TODO [relays] in future may be required to read groupInfo and user on each iteration for up to date state -- TODO - same for delivery jobs (runDeliveryJobWorker) gInfo <- withStore $ \db -> do user <- getUserByGroupId db groupId getGroupInfo db vr user groupId forever $ do unless (delay == 0) $ liftIO $ threadDelay' delay lift $ waitForWork doWork runDeliveryTaskOperation vr gInfo where (groupId, workerScope) = deliveryKey runDeliveryTaskOperation :: VersionRangeChat -> GroupInfo -> CM () runDeliveryTaskOperation vr gInfo = do withWork_ a doWork (withStore' $ \db -> getNextDeliveryTask db deliveryKey) $ \task -> processDeliveryTask task `catchAllErrors` \e -> do withStore' $ \db -> setDeliveryTaskErrStatus db (deliveryTaskId task) (tshow e) eToView e where processDeliveryTask :: MessageDeliveryTask -> CM () processDeliveryTask task@MessageDeliveryTask {jobScope} = case jobScopeImpliedSpec jobScope of DJDeliveryJob _includePending -> withWorkItems a doWork (withStore' $ \db -> getNextDeliveryTasks db gInfo task) $ \nextTasks -> do let (body, taskIds, largeTaskIds) = batchDeliveryTasks1 vr maxEncodedMsgLength nextTasks withStore' $ \db -> do createMsgDeliveryJob db gInfo jobScope (singleSenderGMId_ nextTasks) body forM_ taskIds $ \taskId -> updateDeliveryTaskStatus db taskId DTSProcessed forM_ largeTaskIds $ \taskId -> setDeliveryTaskErrStatus db taskId "large" lift . void $ getDeliveryJobWorker True deliveryKey where singleSenderGMId_ :: NonEmpty MessageDeliveryTask -> Maybe GroupMemberId singleSenderGMId_ (MessageDeliveryTask {senderGMId = senderGMId'} :| ts) | all (\MessageDeliveryTask {senderGMId} -> senderGMId == senderGMId') ts = Just senderGMId' | otherwise = Nothing DJRelayRemoved | workerScope /= DWSGroup -> throwChatError $ CEInternalError "delivery task worker: relay removed task in wrong worker scope" | otherwise -> do let MessageDeliveryTask {senderGMId, fwdSender, brokerTs = fwdBrokerTs, verifiedMsg} = task fwd = GrpMsgForward {fwdSender, fwdBrokerTs} body = encodeBinaryBatch [encodeFwdElement fwd verifiedMsg] withStore' $ \db -> do createMsgDeliveryJob db gInfo jobScope (Just senderGMId) body updateDeliveryTaskStatus db (deliveryTaskId task) DTSProcessed lift . void $ getDeliveryJobWorker True deliveryKey startDeliveryJobWorkers :: CM () startDeliveryJobWorkers = do workerScopes <- withStore' $ \db -> getPendingDeliveryJobScopes db lift $ forM_ workerScopes resumeDeliveryJobWork resumeDeliveryJobWork :: DeliveryWorkerKey -> CM' () resumeDeliveryJobWork = void . getDeliveryJobWorker False getDeliveryJobWorker :: Bool -> DeliveryWorkerKey -> CM' Worker getDeliveryJobWorker hasWork deliveryKey = do ws <- asks deliveryJobWorkers a <- asks smpAgent getAgentWorker "delivery_job" hasWork a deliveryKey ws $ runDeliveryJobWorker a deliveryKey runDeliveryJobWorker :: AgentClient -> DeliveryWorkerKey -> Worker -> CM () runDeliveryJobWorker a deliveryKey Worker {doWork} = do delay <- asks $ deliveryWorkerDelay . config vr <- chatVersionRange (user, gInfo) <- withStore $ \db -> do user <- getUserByGroupId db groupId gInfo <- getGroupInfo db vr user groupId pure (user, gInfo) forever $ do unless (delay == 0) $ liftIO $ threadDelay' delay lift $ waitForWork doWork runDeliveryJobOperation vr user gInfo where (groupId, workerScope) = deliveryKey runDeliveryJobOperation :: VersionRangeChat -> User -> GroupInfo -> CM () runDeliveryJobOperation vr user gInfo = do withWork_ a doWork (withStore' $ \db -> getNextDeliveryJob db deliveryKey) $ \job -> processDeliveryJob job `catchAllErrors` \e -> do withStore' $ \db -> setDeliveryJobErrStatus db (deliveryJobId job) (tshow e) eToView e where processDeliveryJob :: MessageDeliveryJob -> CM () processDeliveryJob job = case jobScopeImpliedSpec jobScope of DJDeliveryJob _includePending -> do sendBodyToMembers withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete DJRelayRemoved | workerScope /= DWSGroup -> throwChatError $ CEInternalError "delivery job worker: relay removed job in wrong worker scope" | otherwise -> do sendBodyToMembers deleteGroupConnections user gInfo True withStore' $ \db -> updateDeliveryJobStatus db jobId DJSComplete where MessageDeliveryJob {jobId, jobScope, singleSenderGMId_, body, cursorGMId_ = startingCursor} = job sendBodyToMembers :: CM () sendBodyToMembers -- channel | useRelays' gInfo = case jobScope of -- there's no member review in channels, so job spec includePending is ignored DJSGroup {} -> do bucketSize <- asks $ deliveryBucketSize . config sendLoop bucketSize startingCursor where sendLoop :: Int -> Maybe GroupMemberId -> CM () sendLoop bucketSize cursorGMId_ = do mems <- withStore' $ \db -> getGroupMembersByCursor db vr user gInfo cursorGMId_ singleSenderGMId_ bucketSize unless (null mems) $ do deliver body mems let cursorGMId' = groupMemberId' $ last mems withStore' $ \db -> updateDeliveryJobCursor db jobId cursorGMId' unless (length mems < bucketSize) $ sendLoop bucketSize (Just cursorGMId') DJSMemberSupport scopeGMId -> do -- for member support scope we just load all recipients in one go, without cursor modMs <- withStore' $ \db -> getGroupModerators db vr user gInfo let moderatorFilter m = memberCurrent m && maxVersion (memberChatVRange m) >= groupKnockingVersion && Just (groupMemberId' m) /= singleSenderGMId_ modMs' = filter moderatorFilter modMs mems <- if Just scopeGMId == singleSenderGMId_ then pure modMs' else do scopeMem <- withStore $ \db -> getGroupMemberById db vr user scopeGMId pure $ scopeMem : modMs' unless (null mems) $ deliver body mems -- fully connected group | otherwise = case singleSenderGMId_ of Nothing -> throwChatError $ CEInternalError "delivery job worker: singleSenderGMId is required when not using relays" Just singleSenderGMId -> do sender <- withStore $ \db -> getGroupMemberById db vr user singleSenderGMId ms <- buildMemberList sender unless (null ms) $ deliver body ms where buildMemberList sender = do vec <- withStore (`getMemberRelationsVector` sender) -- this excludes the sender let introducedMemsIdxs = getRelationsIndexes MRIntroduced vec case jobScope of DJSGroup {jobSpec} -> do ms <- withStore' $ \db -> getGroupMembersByIndexes db vr user gInfo introducedMemsIdxs pure $ filter shouldForwardTo ms where shouldForwardTo m | jobSpecImpliedPending jobSpec = memberCurrentOrPending m | otherwise = memberCurrent m DJSMemberSupport scopeGMId -> do ms <- withStore' $ \db -> getSupportScopeMembersByIndexes db vr user gInfo scopeGMId introducedMemsIdxs pure $ filter shouldForwardTo ms where shouldForwardTo m = groupMemberId' m == scopeGMId || currentModerator m currentModerator m@GroupMember {memberRole} = memberRole >= GRModerator && memberCurrent m && maxVersion (memberChatVRange m) >= groupKnockingVersion where deliver :: ByteString -> [GroupMember] -> CM () deliver msgBody mems = let mConns = mapMaybe (fmap snd . readyMemberConn) mems msgReqs = foldMemConns mConns in void $ withAgent (`sendMessages` msgReqs) where foldMemConns :: [Connection] -> [MsgReq] foldMemConns mConns = snd $ foldr' addReq (lastMemIdx_, []) mConns where lastMemIdx_ = let len = length mConns in if len > 1 then Just len else Nothing addReq :: Connection -> (Maybe Int, [MsgReq]) -> (Maybe Int, [MsgReq]) addReq conn (memIdx_, reqs) = (subtract 1 <$> memIdx_, req : reqs) where req = (aConnId conn, PQEncOff, MsgFlags False, vrValue_) vrValue_ = case memIdx_ of Nothing -> VRValue Nothing msgBody -- sending to one member, do not reference body Just 1 -> VRValue (Just 1) msgBody Just _ -> VRRef 1 -- Single worker processes all relay requests (XGrpRelayInv). -- We use map with a single key 1 to fit into existing worker management framework. relayRequestWorkerKey :: Int relayRequestWorkerKey = 1 startRelayRequestWorker :: CM () startRelayRequestWorker = do hasPending <- withStore' hasPendingRelayRequests when hasPending $ lift resumeRelayRequestWork resumeRelayRequestWork :: CM' () resumeRelayRequestWork = void $ getRelayRequestWorker False getRelayRequestWorker :: Bool -> CM' Worker getRelayRequestWorker hasWork = do ws <- asks relayRequestWorkers a <- asks smpAgent getAgentWorker "relay_request" hasWork a relayRequestWorkerKey ws $ runRelayRequestWorker a runRelayRequestWorker :: AgentClient -> Worker -> CM () runRelayRequestWorker a Worker {doWork} = do vr <- chatVersionRange (user, uclId) <- withStore $ \db -> do user <- getRelayUser db UserContactLink {userContactLinkId} <- getUserAddress db user pure (user, userContactLinkId) forever $ do lift $ waitForWork doWork runRelayRequestOperation vr user uclId where runRelayRequestOperation :: VersionRangeChat -> User -> Int64 -> CM () runRelayRequestOperation vr user uclId = withWork_ a doWork (withStore' getNextPendingRelayRequest) $ \(groupId, rrd) -> do ri <- asks $ reconnectInterval . agentConfig . config withRetryInterval ri $ \_ loop -> do liftIO $ waitWhileSuspended a liftIO $ waitForUserNetwork a processRelayRequest groupId rrd `catchAllErrors` retryTmpError loop groupId where retryTmpError :: CM () -> GroupId -> ChatError -> CM () retryTmpError loop groupId = \case ChatErrorAgent {agentError} | temporaryOrHostError agentError -> loop e -> do withStore' $ \db -> setRelayRequestErr db groupId (tshow e) eToView e processRelayRequest :: GroupId -> RelayRequestData -> CM () processRelayRequest groupId rrd = do (gInfo, groupLink_) <- withStore $ \db -> do gInfo <- getGroupInfo db vr user groupId groupLink_ <- liftIO $ runExceptT $ getGroupLink db user gInfo pure (gInfo, groupLink_) -- Check if relay link already exists (recovery case) case groupLink_ of Right GroupLink {connLinkContact = CCLink _ sLnk_} -> case (sLnk_, memberPubKey $ membership gInfo) of (Just sLnk, Just k) -> acceptOwnerConnection rrd gInfo sLnk (MemberKey k) (Nothing, _) -> throwChatError $ CEException "processRelayRequest: relay link doesn't have short link" (_, Nothing) -> throwChatError $ CEException "processRelayRequest: no member key" Left _ -> do (gInfo', sLnk, memberKey) <- getLinkDataCreateRelayLink rrd gInfo acceptOwnerConnection rrd gInfo' sLnk memberKey where getLinkDataCreateRelayLink :: RelayRequestData -> GroupInfo -> CM (GroupInfo, ShortLinkContact, MemberKey) getLinkDataCreateRelayLink RelayRequestData {reqGroupLink} gInfo = do (FixedLinkData {linkEntityId, rootKey}, cData@(ContactLinkData _ UserContactData {owners})) <- getShortLinkConnReq NRMBackground user reqGroupLink liftIO (decodeLinkUserData cData) >>= \case Nothing -> throwChatError $ CEException "getLinkDataCreateRelayLink: no group link data" Just GroupShortLinkData {groupProfile = gp@GroupProfile {sharedGroupId}} -> do unless ((B64UrlByteString <$> linkEntityId) == sharedGroupId) $ throwChatError $ CEException "getLinkDataCreateRelayLink: linkEntityId does not match profile sharedGroupId" validateGroupProfile gp gVar <- asks random (_, memberPrivKey) <- liftIO $ atomically $ C.generateKeyPair gVar gInfo' <- withStore $ \db -> do void $ updateGroupProfile db user gInfo gp updateRelayGroupKeys db user gInfo linkEntityId rootKey memberPrivKey owners getGroupInfo db vr user groupId sLnk <- createRelayLink gInfo' pure (gInfo', sLnk, MemberKey $ C.publicKey memberPrivKey) where validateGroupProfile :: GroupProfile -> CM () validateGroupProfile _groupProfile = do -- TODO [relays] relay: validate group profile, verify owner's signature pure () createRelayLink :: GroupInfo -> CM ShortLinkContact createRelayLink gi@GroupInfo {groupProfile} = do -- TODO [relays] relay: set relay link data -- TODO - link data: relay key for group, relay identity (profile, certificate, relay identity key) -- TODO - starting role should be communicated in protocol from owner to relays groupLinkId <- GroupLinkId <$> drgRandomBytes 16 subMode <- chatReadVar subscriptionMode subRole <- asks $ channelSubscriberRole . config let userData = encodeShortLinkData $ GroupShortLinkData {groupProfile, publicGroupData = Nothing} userLinkData = UserContactLinkData UserContactData {direct = True, owners = [], relays = [], userData} crClientData = encodeJSON $ CRDataGroup groupLinkId (connId, (ccLink, _serviceId)) <- withAgent $ \a' -> createConnection a' NRMBackground (aUserId user) True True SCMContact (Just userLinkData) (Just crClientData) CR.IKPQOff subMode ccLink' <- createdGroupLink <$> shortenCreatedLink ccLink sLnk <- case toShortLinkContact ccLink' of Just sl -> pure sl Nothing -> throwChatError $ CEException "failed to create relay link: no short link" gVar <- asks random void $ withFastStore $ \db -> createGroupLink db gVar user gi connId ccLink' groupLinkId subRole subMode pure sLnk acceptOwnerConnection :: RelayRequestData -> GroupInfo -> ShortLinkContact -> MemberKey -> CM () acceptOwnerConnection RelayRequestData {relayInvId, reqChatVRange} gi relayLink memberKey = do ownerMember <- withStore $ \db -> getHostMember db vr user groupId void $ acceptRelayJoinRequestAsync user uclId gi ownerMember relayInvId reqChatVRange relayLink memberKey -- TODO [relays] relay: group invite accepted event, chat item (?) pure ()