2024-12-20 16:54:24 +04:00
{- # LANGUAGE DataKinds # -}
{- # LANGUAGE DuplicateRecordFields # -}
{- # LANGUAGE FlexibleContexts # -}
{- # LANGUAGE GADTs # -}
{- # LANGUAGE KindSignatures # -}
{- # LANGUAGE LambdaCase # -}
{- # LANGUAGE NamedFieldPuns # -}
{- # LANGUAGE OverloadedLists # -}
{- # LANGUAGE OverloadedStrings # -}
{- # LANGUAGE PatternSynonyms # -}
{- # LANGUAGE RankNTypes # -}
{- # LANGUAGE ScopedTypeVariables # -}
{- # LANGUAGE TupleSections # -}
{- # LANGUAGE TypeApplications # -}
{- # OPTIONS_GHC - fno - warn - ambiguous - fields # -}
module Simplex.Chat.Library.Subscriber where
import Control.Logger.Simple
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import qualified Data.Aeson as J
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Either ( lefts , partitionEithers , rights )
import Data.Functor ( ( $> ) )
import Data.Int ( Int64 )
2025-03-03 18:57:29 +00:00
import Data.List ( foldl' )
import Data.List.NonEmpty ( NonEmpty ( .. ) )
2024-12-20 16:54:24 +04:00
import qualified Data.List.NonEmpty as L
2025-01-29 13:04:48 +00:00
import Data.Map.Strict ( Map )
2024-12-20 16:54:24 +04:00
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 )
2025-03-03 18:57:29 +00:00
import Data.Time.Clock ( UTCTime , diffUTCTime )
2024-12-20 16:54:24 +04:00
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
2025-01-10 15:27:29 +04:00
import Simplex.Chat.Library.Internal
2024-12-20 16:54:24 +04:00
import Simplex.Chat.Messages
import Simplex.Chat.Messages.CIContent
import Simplex.Chat.Messages.CIContent.Events
2025-03-03 18:57:29 +00:00
import Simplex.Chat.ProfileGenerator ( generateRandomProfile )
2024-12-20 16:54:24 +04:00
import Simplex.Chat.Protocol
import Simplex.Chat.Store
import Simplex.Chat.Store.Connections
2025-06-25 18:04:33 +04:00
import Simplex.Chat.Store.ContactRequest
2024-12-20 16:54:24 +04:00
import Simplex.Chat.Store.Direct
import Simplex.Chat.Store.Files
import Simplex.Chat.Store.Groups
import Simplex.Chat.Store.Messages
import Simplex.Chat.Store.Profiles
import Simplex.Chat.Store.Shared
import Simplex.Chat.Types
import Simplex.Chat.Types.Preferences
import Simplex.Chat.Types.Shared
import Simplex.FileTransfer.Description ( ValidFileDescription )
import qualified Simplex.FileTransfer.Description as FD
import Simplex.FileTransfer.Protocol ( FilePartyI )
import qualified Simplex.FileTransfer.Transport as XFTP
import Simplex.FileTransfer.Types ( FileErrorType ( .. ) , RcvFileId , SndFileId )
import Simplex.Messaging.Agent as Agent
import Simplex.Messaging.Agent.Protocol
import qualified Simplex.Messaging.Agent.Protocol as AP ( AgentErrorType ( .. ) )
2025-01-10 15:27:29 +04:00
import qualified Simplex.Messaging.Agent.Store.DB as DB
2024-12-20 16:54:24 +04:00
import Simplex.Messaging.Client ( ProxyClientError ( .. ) )
import qualified Simplex.Messaging.Crypto as C
import Simplex.Messaging.Crypto.File ( CryptoFile ( .. ) )
import Simplex.Messaging.Crypto.Ratchet ( PQEncryption ( .. ) , PQSupport ( .. ) , pattern PQEncOff , pattern PQEncOn , pattern PQSupportOff , pattern PQSupportOn )
import qualified Simplex.Messaging.Crypto.Ratchet as CR
import Simplex.Messaging.Encoding.String
import Simplex.Messaging.Protocol ( ErrorType ( .. ) , MsgFlags ( .. ) )
import qualified Simplex.Messaging.Protocol as SMP
import qualified Simplex.Messaging.TMap as TM
import Simplex.Messaging.Transport ( TransportError ( .. ) )
import Simplex.Messaging.Util
import Simplex.Messaging.Version
import qualified System.FilePath as FP
import Text.Read ( readMaybe )
import UnliftIO.Directory
import UnliftIO.STM
smallGroupsRcptsMemLimit :: Int
smallGroupsRcptsMemLimit = 20
processAgentMessage :: ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
2025-01-25 14:18:24 +00:00
processAgentMessage _ _ ( DEL_RCVQS delQs ) =
2025-05-04 22:14:36 +01:00
toView $ CEvtAgentRcvQueuesDeleted $ L . map rcvQ delQs
2025-01-25 14:18:24 +00:00
where
rcvQ ( connId , server , rcvId , err_ ) = DeletedRcvQueue ( AgentConnId connId ) server ( AgentQueueId rcvId ) err_
processAgentMessage _ _ ( DEL_CONNS connIds ) =
2025-05-04 22:14:36 +01:00
toView $ CEvtAgentConnsDeleted $ L . map AgentConnId connIds
2024-12-20 16:54:24 +04:00
processAgentMessage _ " " ( ERR e ) =
2025-05-05 11:51:22 +01:00
eToView $ ChatErrorAgent e Nothing
2024-12-20 16:54:24 +04:00
processAgentMessage corrId connId msg = do
lockEntity <- critical ( withStore ( ` getChatLockEntity ` AgentConnId connId ) )
withEntityLock " processAgentMessage " lockEntity $ do
vr <- chatVersionRange
-- getUserByAConnId never throws logical errors, only SEDBBusyError can be thrown here
critical ( withStore' ( ` getUserByAConnId ` AgentConnId connId ) ) >>= \ case
2025-05-05 11:51:22 +01:00
Just user -> processAgentMessageConn vr user corrId connId msg ` catchChatError ` eToView
2024-12-20 16:54:24 +04:00
_ -> throwChatError $ CENoConnectionUser ( AgentConnId connId )
-- CRITICAL error will be shown to the user as alert with restart button in Android/desktop apps.
-- SEDBBusyError will only be thrown on IO exceptions or SQLError during DB queries,
-- e.g. when database is locked or busy for longer than 3s.
-- In this case there is no better mitigation than showing alert:
-- - without ACK the message delivery will be stuck,
-- - with ACK message will be lost, as it failed to be saved.
-- Full app restart is likely to resolve database condition and the message will be received and processed again.
critical :: CM a -> CM a
critical a =
a ` catchChatError ` \ case
ChatErrorStore SEDBBusyError { message } -> throwError $ ChatErrorAgent ( CRITICAL True message ) Nothing
e -> throwError e
processAgentMessageNoConn :: AEvent 'AENone -> CM ()
processAgentMessageNoConn = \ case
2025-05-04 22:14:36 +01:00
CONNECT p h -> hostEvent $ CEvtHostConnected p h
DISCONNECT p h -> hostEvent $ CEvtHostDisconnected p h
DOWN srv conns -> serverEvent srv conns NSDisconnected CEvtContactsDisconnected
UP srv conns -> serverEvent srv conns NSConnected CEvtContactsSubscribed
SUSPENDED -> toView CEvtChatSuspended
DEL_USER agentUserId -> toView $ CEvtAgentUserDeleted agentUserId
2024-12-20 16:54:24 +04:00
ERRS cErrs -> errsEvent cErrs
where
2025-05-04 22:14:36 +01:00
hostEvent :: ChatEvent -> CM ()
2024-12-20 16:54:24 +04:00
hostEvent = whenM ( asks $ hostEvents . config ) . toView
serverEvent srv conns nsStatus event = do
chatModifyVar connNetworkStatuses $ \ m -> foldl' ( \ m' cId -> M . insert cId nsStatus m' ) m connIds
ifM ( asks $ coreApi . config ) ( notifyAPI connIds ) notifyCLI
where
connIds = map AgentConnId conns
2025-05-04 22:14:36 +01:00
notifyAPI = toView . CEvtNetworkStatus nsStatus
2024-12-20 16:54:24 +04:00
notifyCLI = do
cs <- withStore' ( ` getConnectionsContacts ` conns )
toView $ event srv cs
errsEvent :: [ ( ConnId , AgentErrorType ) ] -> CM ()
errsEvent cErrs = do
vr <- chatVersionRange
errs <- lift $ rights <$> withStoreBatch' ( \ db -> map ( getChatErr vr db ) cErrs )
2025-05-05 11:51:22 +01:00
toView $ CEvtChatErrors errs
2024-12-20 16:54:24 +04:00
where
getChatErr :: VersionRangeChat -> DB . Connection -> ( ConnId , AgentErrorType ) -> IO ChatError
getChatErr vr db ( connId , err ) =
let acId = AgentConnId connId
in ChatErrorAgent err <$> ( getUserByAConnId db acId $>>= \ user -> eitherToMaybe <$> runExceptT ( getConnectionEntity db vr user acId ) )
processAgentMsgSndFile :: ACorrId -> SndFileId -> AEvent 'AESndFile -> CM ()
processAgentMsgSndFile _corrId aFileId msg = do
( cRef_ , fileId ) <- withStore ( ` getXFTPSndFileDBIds ` AgentSndFileId aFileId )
withEntityLock_ cRef_ . withFileLock " processAgentMsgSndFile " fileId $
withStore' ( ` getUserByASndFileId ` AgentSndFileId aFileId ) >>= \ case
2025-05-05 11:51:22 +01:00
Just user -> process user fileId ` catchChatError ` eToView
2024-12-20 16:54:24 +04:00
_ -> do
lift $ withAgent' ( ` xftpDeleteSndFileInternal ` aFileId )
throwChatError $ CENoSndFileUser $ AgentSndFileId aFileId
where
withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
2025-04-02 07:57:18 +00:00
withEntityLock_ = \ case
Just ( ChatRef CTDirect contactId _ ) -> withContactLock " processAgentMsgSndFile " contactId
Just ( ChatRef CTGroup groupId _scope ) -> withGroupLock " processAgentMsgSndFile " groupId
2024-12-20 16:54:24 +04:00
_ -> 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
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileProgressXFTP user ci ft sndProgress sndTotal
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
Nothing -> xftpSndFileRedirect user fileId rfd >>= toView . CEvtSndFileRedirectStartXFTP user ft
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtSndStandaloneFileComplete user ft' $ map ( decodeLatin1 . strEncode . FD . fileDescriptionURI ) rfds'
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileProgressXFTP user ci ft 1 1
2024-12-20 16:54:24 +04:00
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
2025-05-05 11:51:22 +01:00
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 "
2024-12-20 16:54:24 +04:00
lift $ withAgent' ( ` xftpDeleteSndFileInternal ` aFileId )
2025-04-02 07:57:18 +00:00
( _ , _ , SMDSnd , GroupChat g @ GroupInfo { groupId } _scope ) -> do
2024-12-20 16:54:24 +04:00
ms <- withStore' $ \ db -> getGroupMembers db vr user g
let rfdsMemberFTs = zipWith ( \ rfd ( conn , sft ) -> ( conn , sft , fileDescrText rfd ) ) rfds ( memberFTs ms )
extraRFDs = drop ( length rfdsMemberFTs ) rfds
withStore' $ \ db -> createExtraSndFTDescrs db user fileId ( map fileDescrText extraRFDs )
forM_ ( L . nonEmpty rfdsMemberFTs ) $ \ rfdsMemberFTs' ->
sendFileDescriptions ( GroupId groupId ) rfdsMemberFTs' sharedMsgId
ci' <- withStore $ \ db -> do
liftIO $ updateCIFileStatus db user fileId CIFSSndComplete
getChatItemByFileId db vr user fileId
lift $ withAgent' ( ` xftpDeleteSndFileInternal ` aFileId )
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileCompleteXFTP user ci' ft
2024-12-20 16:54:24 +04:00
where
memberFTs :: [ GroupMember ] -> [ ( Connection , SndFileTransfer ) ]
memberFTs ms = M . elems $ M . intersectionWith ( , ) ( M . fromList mConns' ) ( M . fromList sfts' )
where
mConns' = mapMaybe useMember ms
sfts' = mapMaybe ( \ sft @ SndFileTransfer { groupMemberId } -> ( , sft ) <$> groupMemberId ) sfts
-- Should match memberSendAction logic
useMember GroupMember { groupMemberId , activeConn = Just conn @ Connection { connStatus } }
| ( connStatus == ConnReady || connStatus == ConnSndReady ) && not ( connDisabled conn ) && not ( connInactive conn ) =
Just ( groupMemberId , conn )
| otherwise = Nothing
useMember _ = Nothing
_ -> pure ()
_ -> pure () -- TODO error?
SFWARN e -> do
let err = tshow e
logWarn $ " Sent file warning: " <> err
ci <- withStore $ \ db -> do
liftIO $ updateCIFileStatus db user fileId ( CIFSSndWarning $ agentFileError e )
lookupChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileWarning user ci ft err
2024-12-20 16:54:24 +04:00
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
2025-05-05 11:51:22 +01:00
unless ( null errs' ) $ toView $ CEvtChatErrors errs'
2024-12-20 16:54:24 +04:00
pure delivered
where
connDescrEvents :: Int -> NonEmpty ( Connection , ( ConnOrGroupId , ChatMsgEvent 'Json ) )
connDescrEvents partSize = L . fromList $ concatMap splitText ( L . toList connsTransfersDescrs )
where
splitText :: ( Connection , SndFileTransfer , RcvFileDescrText ) -> [ ( Connection , ( ConnOrGroupId , ChatMsgEvent 'Json ) ) ]
splitText ( conn , _ , rfdText ) =
map ( \ fileDescr -> ( conn , ( connOrGroupId , XMsgFileDescr { msgId = sharedMsgId , fileDescr } ) ) ) ( L . toList $ splitFileDescr partSize rfdText )
toMsgReq :: ( Connection , ( ConnOrGroupId , ChatMsgEvent 'Json ) ) -> SndMessage -> ChatMsgReq
toMsgReq ( conn , _ ) SndMessage { msgId , msgBody } =
2025-02-15 00:12:32 +04:00
( conn , MsgFlags { notification = hasNotification XMsgFileDescr_ } , ( vrValue msgBody , [ msgId ] ) )
2024-12-20 16:54:24 +04:00
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 )
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileError user ci ft err
2024-12-20 16:54:24 +04:00
agentFileError :: AgentErrorType -> FileError
agentFileError = \ case
XFTP _ XFTP . AUTH -> FileErrAuth
2025-01-12 21:25:25 +00:00
XFTP srv ( XFTP . BLOCKED info ) -> FileErrBlocked srv info
2024-12-20 16:54:24 +04:00
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
2025-05-05 11:51:22 +01:00
Just user -> process user fileId ` catchChatError ` eToView
2024-12-20 16:54:24 +04:00
_ -> do
lift $ withAgent' ( ` xftpDeleteRcvFile ` aFileId )
throwChatError $ CENoRcvFileUser $ AgentRcvFileId aFileId
where
withEntityLock_ :: Maybe ChatRef -> CM a -> CM a
2025-04-02 07:57:18 +00:00
withEntityLock_ = \ case
Just ( ChatRef CTDirect contactId _ ) -> withContactLock " processAgentMsgRcvFile " contactId
Just ( ChatRef CTGroup groupId _scope ) -> withGroupLock " processAgentMsgRcvFile " groupId
2024-12-20 16:54:24 +04:00
_ -> 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
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileProgressXFTP user ci rcvProgress rcvTotal ft
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ maybe ( CEvtRcvStandaloneFileComplete user fsTargetPath ft ) ( CEvtRcvFileComplete user ) ci_
2024-12-20 16:54:24 +04:00
RFWARN e -> do
ci <- withStore $ \ db -> do
liftIO $ updateCIFileStatus db user fileId ( CIFSRcvWarning $ agentFileError e )
lookupChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileWarning user ci e ft
2024-12-20 16:54:24 +04:00
RFERR e
| e == FILE NOT_APPROVED -> do
aci_ <- resetRcvCIFileStatus user fileId CIFSRcvAborted
forM_ aci_ cleanupACIFile
agentXFTPDeleteRcvFile aFileId fileId
2025-05-04 22:14:36 +01:00
forM_ aci_ $ \ aci -> toView $ CEvtChatItemUpdated user aci
2024-12-20 16:54:24 +04:00
| 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
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileError user aci_ e ft
2024-12-20 16:54:24 +04:00
processAgentMessageConn :: VersionRangeChat -> User -> ACorrId -> ConnId -> AEvent 'AEConn -> CM ()
processAgentMessageConn vr user @ User { userId } corrId agentConnId agentMessage = do
-- Missing connection/entity errors here will be sent to the view but not shown as CRITICAL alert,
-- as in this case no need to ACK message - we can't process messages for this connection anyway.
-- SEDBException will be re-trown as CRITICAL as it is likely to indicate a temporary database condition
-- that will be resolved with app restart.
entity <- critical $ withStore ( \ db -> getConnectionEntity db vr user $ AgentConnId agentConnId ) >>= updateConnStatus
case agentMessage of
END -> case entity of
2025-05-04 22:14:36 +01:00
RcvDirectMsgConnection _ ( Just ct ) -> toView $ CEvtContactAnotherClient user ct
_ -> toView $ CEvtSubscriptionEnd user entity
MSGNTF msgId msgTs_ -> toView $ CEvtNtfMessage user entity $ ntfMsgAckInfo msgId msgTs_
2024-12-20 16:54:24 +04:00
_ -> case entity of
RcvDirectMsgConnection conn contact_ ->
processDirectMessage agentMessage entity conn contact_
RcvGroupMsgConnection conn gInfo m ->
processGroupMessage agentMessage entity conn gInfo m
RcvFileConnection conn ft ->
processRcvFileConn agentMessage entity conn ft
SndFileConnection conn ft ->
processSndFileConn agentMessage entity conn ft
UserContactConnection conn uc ->
processUserContactRequest agentMessage entity conn uc
where
updateConnStatus :: ConnectionEntity -> CM ConnectionEntity
updateConnStatus acEntity = case agentMsgConnStatus agentMessage of
Just connStatus -> do
let conn = ( entityConnection acEntity ) { connStatus }
withStore' $ \ db -> updateConnectionStatus db conn connStatus
pure $ updateEntityConnStatus acEntity connStatus
Nothing -> pure acEntity
agentMsgConnStatus :: AEvent e -> Maybe ConnStatus
agentMsgConnStatus = \ case
2025-06-09 18:23:53 +01:00
JOINED True _ -> Just ConnSndReady
2024-12-20 16:54:24 +04:00
CONF { } -> Just ConnRequested
INFO { } -> Just ConnSndReady
CON _ -> Just ConnReady
_ -> Nothing
processCONFpqSupport :: Connection -> PQSupport -> CM Connection
processCONFpqSupport conn @ Connection { connId , pqSupport = pq } pq'
| pq == PQSupportOn && pq' == PQSupportOff = do
let pqEnc' = CR . pqSupportToEnc pq'
withStore' $ \ db -> updateConnSupportPQ db connId pq' pqEnc'
pure ( conn { pqSupport = pq' , pqEncryption = pqEnc' } :: Connection )
| pq /= pq' = do
messageWarning " processCONFpqSupport: unexpected pqSupport change "
pure conn
| otherwise = pure conn
processINFOpqSupport :: Connection -> PQSupport -> CM ()
processINFOpqSupport Connection { pqSupport = pq } pq' =
when ( pq /= pq' ) $ messageWarning " processINFOpqSupport: unexpected pqSupport change "
processDirectMessage :: AEvent e -> ConnectionEntity -> Connection -> Maybe Contact -> CM ()
processDirectMessage agentMsg connEntity conn @ Connection { connId , connChatVersion , peerChatVRange , viaUserContactLink , customUserProfileId , connectionCode } = \ case
Nothing -> case agentMsg of
CONF confId pqSupport _ connInfo -> do
conn' <- processCONFpqSupport conn pqSupport
-- [incognito] send saved profile
( conn'' , inGroup ) <- saveConnInfo conn' connInfo
incognitoProfile <- forM customUserProfileId $ \ profileId -> withStore ( \ db -> getProfileById db userId profileId )
let profileToSend = userProfileToSend user ( fromLocalProfile <$> incognitoProfile ) Nothing inGroup
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
INFO pqSupport connInfo -> do
processINFOpqSupport conn pqSupport
void $ saveConnInfo conn connInfo
MSG meta _msgFlags _msgBody ->
-- We are not saving message (saveDirectRcvMSG) as contact hasn't been created yet,
-- chat item is also not created here
withAckMessage' " new contact msg " agentConnId meta $ pure ()
SENT msgId _proxy -> do
void $ continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
OK ->
-- [async agent commands] continuation on receiving OK
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
JOINED _ _serviceId ->
2024-12-20 16:54:24 +04:00
-- [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
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
processConnMERR connEntity conn err
MERRS _ err -> do
-- error cannot be AUTH error here
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
Just ct @ Contact { contactId } -> case agentMsg of
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
INV ( ACR _ cReq ) _serviceId ->
2024-12-20 16:54:24 +04:00
-- [async agent commands] XGrpMemIntro continuation on receiving INV
withCompletedCommand conn agentMsg $ \ _ ->
case cReq of
directConnReq @ ( CRInvitationUri _ _ ) -> do
contData <- withStore' $ \ db -> do
setConnConnReqInv db user connId cReq
getXGrpMemIntroContDirect db user ct
forM_ contData $ \ ( hostConnId , xGrpMemIntroCont ) ->
sendXGrpMemInv hostConnId ( Just directConnReq ) xGrpMemIntroCont
CRContactUri _ -> throwChatError $ CECommandError " unexpected ConnectionRequestUri type "
MSG msgMeta _msgFlags msgBody -> do
tags <- newTVarIO []
withAckMessage " contact msg " agentConnId msgMeta True ( Just tags ) $ \ eInfo -> do
let MsgMeta { pqEncryption } = msgMeta
( ct' , conn' ) <- updateContactPQRcv user ct conn pqEncryption
checkIntegrityCreateItem ( CDDirectRcv ct' ) msgMeta ` catchChatError ` \ _ -> pure ()
forM_ aChatMsgs $ \ case
Right ( ACMsg _ chatMsg ) ->
2025-05-05 11:51:22 +01:00
processEvent ct' conn' tags eInfo chatMsg ` catchChatError ` \ e -> eToView e
2024-12-20 16:54:24 +04:00
Left e -> do
atomically $ modifyTVar' tags ( " error " : )
logInfo $ " contact msg=error " <> eInfo <> " " <> tshow e
2025-05-05 11:51:22 +01:00
eToView ( ChatError . CEException $ " error parsing chat message: " <> e )
2024-12-20 16:54:24 +04:00
checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent
where
aChatMsgs = parseChatMessages msgBody
processEvent :: Contact -> Connection -> TVar [ Text ] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
processEvent ct' conn' tags eInfo chatMsg @ ChatMessage { chatMsgEvent } = do
let tag = toCMEventTag chatMsgEvent
atomically $ modifyTVar' tags ( tshow tag : )
logInfo $ " contact msg= " <> tshow tag <> " " <> eInfo
( conn'' , msg @ RcvMessage { chatMsgEvent = ACME _ event } ) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg
let ct'' = ct' { activeConn = Just conn'' } :: Contact
case event of
XMsgNew mc -> newContentMessage ct'' mc msg msgMeta
XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr
2025-04-02 07:57:18 +00:00
XMsgUpdate sharedMsgId mContent _ ttl live _msgScope -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live
2024-12-20 16:54:24 +04:00
XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta
XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta
-- TODO discontinue XFile
XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName
XInfo p -> xInfo ct'' p
XDirectDel -> xDirectDel ct'' msg msgMeta
XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta
XInfoProbe probe -> xInfoProbe ( COMContact ct'' ) probe
XInfoProbeCheck probeHash -> xInfoProbeCheck ( COMContact ct'' ) probeHash
XInfoProbeOk probe -> xInfoProbeOk ( COMContact ct'' ) probe
XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta
XCallOffer callId offer -> xCallOffer ct'' callId offer msg
XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg
XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg
XCallEnd callId -> xCallEnd ct'' callId msg
BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta
_ -> messageError $ " unsupported message: " <> T . pack ( show event )
checkSendRcpt :: Contact -> [ AChatMessage ] -> CM Bool
checkSendRcpt ct' aMsgs = do
let Contact { chatSettings = ChatSettings { sendRcpts } } = ct'
pure $ fromMaybe ( sendRcptsContacts user ) sendRcpts && any aChatMsgHasReceipt aMsgs
where
aChatMsgHasReceipt ( ACMsg _ ChatMessage { chatMsgEvent } ) =
hasDeliveryReceipt ( toCMEventTag chatMsgEvent )
RCVD msgMeta msgRcpt ->
withAckMessage' " contact rcvd " agentConnId msgMeta $
directMsgReceived ct conn msgMeta msgRcpt
CONF confId pqSupport _ connInfo -> do
conn' <- processCONFpqSupport conn pqSupport
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn' connInfo
conn'' <- updatePeerChatVRange conn' chatVRange
case chatMsgEvent of
-- confirming direct connection with a member
XGrpMemInfo _memId _memProfile -> do
-- TODO check member ID
-- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn'' confId XOk
XInfo profile -> do
ct' <- processContactProfileUpdate ct profile False ` catchChatError ` const ( pure ct )
-- [incognito] send incognito profile
incognitoProfile <- forM customUserProfileId $ \ profileId -> withStore $ \ db -> getProfileById db userId profileId
let p = userProfileToSend user ( fromLocalProfile <$> incognitoProfile ) ( Just ct' ) False
allowAgentConnectionAsync user conn'' confId $ XInfo p
void $ withStore' $ \ db -> resetMemberContactFields db ct'
XGrpLinkInv glInv -> do
-- XGrpLinkInv here means we are connecting via business contact card, so we replace contact with group
( gInfo , host ) <- withStore $ \ db -> do
liftIO $ deleteContactCardKeepConn db connId ct
createGroupInvitedViaLink db vr user conn'' glInv
-- [incognito] send saved profile
incognitoProfile <- forM customUserProfileId $ \ pId -> withStore ( \ db -> getProfileById db userId pId )
let profileToSend = userProfileToSend user ( fromLocalProfile <$> incognitoProfile ) Nothing True
allowAgentConnectionAsync user conn'' confId $ XInfo profileToSend
2025-05-04 22:14:36 +01:00
toView $ CEvtBusinessLinkConnecting user gInfo host ct
2024-12-20 16:54:24 +04:00
_ -> 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 ()
2025-06-20 11:54:21 +01:00
XInfo profile -> do
2025-06-23 14:42:00 +01:00
let prepared = isJust ( preparedContact ct ) || isJust ( contactRequestId' ct )
2025-06-20 11:54:21 +01:00
void $ processContactProfileUpdate ct profile prepared
2024-12-20 16:54:24 +04:00
XOk -> pure ()
_ -> messageError " INFO for existing contact must have x.grp.mem.info, x.info or x.ok "
CON pqEnc ->
withStore' ( \ db -> getViaGroupMember db vr user ct ) >>= \ case
Nothing -> do
when ( pqEnc == PQEncOn ) $ withStore' $ \ db -> updateConnPQEnabledCON db connId pqEnc
let conn' = conn { pqSndEnabled = Just pqEnc , pqRcvEnabled = Just pqEnc } :: Connection
ct' = ct { activeConn = Just conn' } :: Contact
-- [incognito] print incognito profile used for this contact
incognitoProfile <- forM customUserProfileId $ \ profileId -> withStore ( \ db -> getProfileById db userId profileId )
lift $ setContactNetworkStatus ct' NSConnected
2025-05-04 22:14:36 +01:00
toView $ CEvtContactConnected user ct' ( fmap fromLocalProfile incognitoProfile )
2025-06-20 11:54:21 +01:00
let createE2EItem = createInternalChatItem user ( CDDirectRcv ct' ) ( CIRcvDirectE2EEInfo $ E2EInfo $ Just pqEnc ) Nothing
2025-06-25 18:04:33 +04:00
-- TODO get contact request by contactRequestId, check encryption (UserContactRequest.pqSupport)?
2025-06-23 14:42:00 +01:00
when ( directOrUsed ct' ) $ case ( preparedContact ct' , contactRequestId' ct' ) of
( Nothing , Nothing ) -> do
2025-06-20 11:54:21 +01:00
createE2EItem
createFeatureEnabledItems user ct'
2025-06-23 14:42:00 +01:00
( Just PreparedContact { connLinkToConnect = ACCL _ ( CCLink cReq _ ) } , _ ) ->
unless ( Just pqEnc == connRequestPQEncryption cReq ) createE2EItem
( _ , Just connReqId ) -> do
UserContactRequest { pqSupport } <- withStore $ \ db -> getContactRequest db user connReqId
unless ( CR . pqSupportToEnc pqSupport == pqEnc ) createE2EItem
2024-12-20 16:54:24 +04:00
when ( contactConnInitiated conn' ) $ do
let Connection { groupLinkId } = conn'
doProbeContacts = isJust groupLinkId
probeMatchingContactsAndMembers ct' ( contactConnIncognito ct' ) doProbeContacts
withStore' $ \ db -> resetContactConnInitiated db user conn'
forM_ viaUserContactLink $ \ userContactLinkId -> do
2025-06-10 15:12:23 +00:00
( ucl , gli_ ) <- withStore $ \ db -> getUserContactLinkById db userId userContactLinkId
when ( connChatVersion < batchSend2Version ) $ sendAutoReply ucl ct'
2025-03-03 18:57:29 +00:00
-- TODO REMOVE LEGACY vvv
forM_ gli_ $ \ GroupLinkInfo { groupId , memberRole = gLinkMemRole } -> do
2024-12-20 16:54:24 +04:00
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
2025-03-03 18:57:29 +00:00
-- TODO REMOVE LEGACY ^^^
2024-12-20 16:54:24 +04:00
Just ( gInfo , m @ GroupMember { activeConn } ) ->
when ( maybe False ( ( == ConnReady ) . connStatus ) activeConn ) $ do
notifyMemberConnected gInfo m $ Just ct
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
when ( memberCategory m == GCPreMember ) $ probeMatchingContactsAndMembers ct connectedIncognito True
SENT msgId proxy -> do
void $ continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
cis <- withStore $ \ db -> do
cis <- updateDirectItemsStatus' db ct conn msgId ( CISSndSent SSPComplete )
liftIO $ forM cis $ \ ci -> setDirectSndChatItemViaProxy db user ct ci ( isJust proxy )
let acis = map ctItem cis
2025-05-04 22:14:36 +01:00
unless ( null acis ) $ toView $ CEvtChatItemsStatusesUpdated user acis
2024-12-20 16:54:24 +04:00
where
ctItem = AChatItem SCTDirect SMDSnd ( DirectChat ct )
SWITCH qd phase cStats -> do
2025-05-04 22:14:36 +01:00
toView $ CEvtContactSwitch user ct ( SwitchProgress qd phase cStats )
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
Just ci -> toView $ CEvtChatItemUpdated user ( AChatItem SCTDirect SMDRcv ( DirectChat ct ) ci )
2024-12-20 16:54:24 +04:00
_ -> do
2025-05-04 22:14:36 +01:00
toView $ CEvtContactRatchetSync user ct ( RatchetSyncProgress rss cStats )
2024-12-20 16:54:24 +04:00
createInternalChatItem user ( CDDirectRcv ct ) ( CIRcvDecryptionError mde n ) Nothing
ratchetSyncEventItem ct' = do
2025-05-04 22:14:36 +01:00
toView $ CEvtContactRatchetSync user ct' ( RatchetSyncProgress rss cStats )
2024-12-20 16:54:24 +04:00
createInternalChatItem user ( CDDirectRcv ct' ) ( CIRcvConnEvent $ RCERatchetSync rss ) Nothing
OK ->
-- [async agent commands] continuation on receiving OK
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
JOINED sqSecured _serviceId ->
2024-12-20 16:54:24 +04:00
-- [async agent commands] continuation on receiving JOINED
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData ->
when ( directOrUsed ct && sqSecured ) $ do
lift $ setContactNetworkStatus ct NSConnected
2025-05-04 22:14:36 +01:00
toView $ CEvtContactSndReady user ct
2024-12-20 16:54:24 +04:00
forM_ viaUserContactLink $ \ userContactLinkId -> do
2025-06-10 15:12:23 +00:00
( ucl , _ ) <- withStore $ \ db -> getUserContactLinkById db userId userContactLinkId
when ( connChatVersion >= batchSend2Version ) $ sendAutoReply ucl ct
2024-12-20 16:54:24 +04:00
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 )
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
processConnMERR connEntity conn err
MERRS msgIds err -> do
-- error cannot be AUTH error here
updateDirectItemsStatusMsgs ct conn ( L . toList msgIds ) ( CISSndError $ agentSndError err )
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
where
2025-06-23 14:42:00 +01:00
sendAutoReply UserContactLink { addressSettings = AddressSettings { autoReply } } ct =
forM_ autoReply $ \ mc -> 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 ]
2024-12-20 16:54:24 +04:00
processGroupMessage :: AEvent e -> ConnectionEntity -> Connection -> GroupInfo -> GroupMember -> CM ()
2025-06-05 13:16:04 +00:00
processGroupMessage agentMsg connEntity conn @ Connection { connId , connChatVersion , customUserProfileId , connectionCode } gInfo @ GroupInfo { groupId , groupProfile , membership , chatSettings } m = case agentMsg of
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
INV ( ACR _ cReq ) _serviceId ->
2024-12-20 16:54:24 +04:00
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
2025-01-31 10:32:07 +04:00
| otherwise -> messageError " processGroupMessage INV: member chat version range incompatible "
2024-12-20 16:54:24 +04:00
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 }
2025-03-03 18:57:29 +00:00
-- TODO REMOVE LEGACY vvv
2024-12-20 16:54:24 +04:00
-- [async agent commands] group link auto-accept continuation on receiving INV
CFCreateConnGrpInv -> do
ct <- withStore $ \ db -> getContactViaMember db vr user m
withStore' $ \ db -> setNewContactMemberConnRequest db user m cReq
groupLinkId <- withStore' $ \ db -> getGroupLinkId db user gInfo
sendGrpInvitation ct m groupLinkId
2025-05-04 22:14:36 +01:00
toView $ CEvtSentGroupInvitation user gInfo ct m
2024-12-20 16:54:24 +04:00
where
sendGrpInvitation :: Contact -> GroupMember -> Maybe GroupLinkId -> CM ()
sendGrpInvitation ct GroupMember { memberId , memberRole = memRole } groupLinkId = do
currentMemCount <- withStore' $ \ db -> getGroupCurrentMembersCount db user gInfo
let GroupMember { memberRole = userRole , memberId = userMemberId } = membership
groupInv =
GroupInvitation
{ fromMember = MemberIdRole userMemberId userRole ,
invitedMember = MemberIdRole memberId memRole ,
connRequest = cReq ,
groupProfile ,
business = Nothing ,
groupLinkId = groupLinkId ,
groupSize = Just currentMemCount
}
( _msg , _ ) <- sendDirectContactMessage user ct $ XGrpInv groupInv
-- we could link chat item with sent group invitation message (_msg)
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo Nothing m ) ( CIRcvGroupEvent RGEInvitedViaGroupLink ) Nothing
2025-03-03 18:57:29 +00:00
-- TODO REMOVE LEGACY ^^^
2024-12-20 16:54:24 +04:00
_ -> throwChatError $ CECommandError " unexpected cmdFunction "
CRContactUri _ -> throwChatError $ CECommandError " unexpected ConnectionRequestUri type "
CONF confId _pqSupport _ connInfo -> do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn connInfo
conn' <- updatePeerChatVRange conn chatVRange
case memberCategory m of
GCInviteeMember ->
case chatMsgEvent of
XGrpAcpt memId
| sameMemberId memId m -> do
withStore $ \ db -> liftIO $ updateGroupMemberStatus db userId m GSMemAccepted
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId XOk
| otherwise -> messageError " x.grp.acpt: memberId is different from expected "
_ -> messageError " CONF from invited member must have x.grp.acpt "
2025-06-05 13:16:04 +00:00
GCHostMember ->
case chatMsgEvent of
XGrpLinkInv glInv -> do
-- XGrpLinkInv here means we are connecting via prepared group, and we have to update user and host member records
( 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 = userProfileToSend user ( fromLocalProfile <$> incognitoProfile ) Nothing True
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 "
2024-12-20 16:54:24 +04:00
_ ->
case chatMsgEvent of
XGrpMemInfo memId _memProfile
| sameMemberId memId m -> do
let GroupMember { memberId = membershipMemId } = membership
membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership
-- TODO update member profile
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId $ XGrpMemInfo membershipMemId membershipProfile
| otherwise -> messageError " x.grp.mem.info: memberId is different from expected "
_ -> messageError " CONF from member must have x.grp.mem.info "
INFO _pqSupport connInfo -> do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn connInfo
_conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of
XGrpMemInfo memId _memProfile
| sameMemberId memId m -> do
-- TODO update member profile
pure ()
| otherwise -> messageError " x.grp.mem.info: memberId is different from expected "
2025-02-25 14:05:49 +04:00
-- sent when connecting via group link
XInfo _ ->
2025-03-03 18:57:29 +00:00
-- TODO Keep rejected member to allow them to appeal against rejection.
2025-02-25 14:05:49 +04:00
when ( memberStatus m == GSMemRejected ) $ do
2025-05-05 11:51:22 +01:00
deleteMemberConnection' m True
2025-02-25 14:05:49 +04:00
withStore' $ \ db -> deleteGroupMember db user m
2024-12-20 16:54:24 +04:00
XOk -> pure ()
_ -> messageError " INFO from member must have x.grp.mem.info, x.info or x.ok "
pure ()
2025-04-02 07:57:18 +00:00
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 m conn
2024-12-20 16:54:24 +04:00
withAgent $ \ a -> toggleConnectionNtfs a ( aConnId conn ) $ chatHasNtfs chatSettings
case memberCategory m of
GCHostMember -> do
2025-05-14 11:25:24 +00:00
( m' , gInfo' ) <- withStore' $ \ db -> do
2025-04-02 07:57:18 +00:00
updateGroupMemberStatus db userId m GSMemConnected
2025-05-14 11:25:24 +00:00
gInfo' <-
2025-04-02 07:57:18 +00:00
if not ( memberPending membership )
2025-05-14 11:25:24 +00:00
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'
let cd = CDGroupRcv gInfo'' scopeInfo m''
2025-06-20 11:54:21 +01:00
createInternalChatItem user cd ( CIRcvGroupE2EEInfo E2EInfo { pqEnabled = Just PQEncOff } ) Nothing
2025-05-14 11:25:24 +00:00
createGroupFeatureItems user cd CIRcvGroupFeature gInfo''
memberConnectedChatItem gInfo'' scopeInfo m''
unless ( memberPending membership ) $ maybeCreateGroupDescrLocal gInfo'' m''
2024-12-20 16:54:24 +04:00
GCInviteeMember -> do
2025-05-09 15:36:06 +00:00
( gInfo' , mStatus ) <-
2025-04-02 07:57:18 +00:00
if not ( memberPending m )
2025-05-09 15:36:06 +00:00
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'
2025-04-28 10:45:42 +00:00
case scopeInfo of
Just ( GCSIMemberSupport _ ) -> do
2025-05-09 15:36:06 +00:00
createInternalChatItem user ( CDGroupRcv gInfo'' scopeInfo m' ) ( CIRcvGroupEvent RGENewMemberPendingReview ) Nothing
2025-04-28 10:45:42 +00:00
_ -> pure ()
2025-05-09 15:36:06 +00:00
toView $ CEvtJoinedGroupMember user gInfo'' m' { memberStatus = mStatus }
2024-12-20 16:54:24 +04:00
let Connection { viaUserContactLink } = conn
2025-05-09 15:36:06 +00:00
when ( isJust viaUserContactLink && isNothing ( memberContactId m' ) ) $ sendXGrpLinkMem gInfo''
2024-12-20 16:54:24 +04:00
when ( connChatVersion < batchSend2Version ) sendGroupAutoReply
2025-04-02 07:57:18 +00:00
case mStatus of
GSMemPendingApproval -> pure ()
2025-05-09 15:36:06 +00:00
GSMemPendingReview -> introduceToModerators vr user gInfo'' m'
2025-04-02 07:57:18 +00:00
_ -> do
2025-05-09 15:36:06 +00:00
introduceToAll vr user gInfo'' m'
when ( groupFeatureAllowed SGFHistory gInfo'' ) $ sendHistory user gInfo'' m'
2024-12-20 16:54:24 +04:00
where
2025-05-09 15:36:06 +00:00
sendXGrpLinkMem gInfo'' = do
let profileMode = ExistingIncognito <$> incognitoMembershipProfile gInfo''
2024-12-20 16:54:24 +04:00
profileToSend = profileToSendOnAccept user profileMode True
void $ sendDirectMemberMessage conn ( XGrpLinkMem profileToSend ) groupId
_ -> do
2025-04-02 07:57:18 +00:00
unless ( memberPending m ) $ withStore' $ \ db -> updateGroupMemberStatus db userId m GSMemConnected
2024-12-20 16:54:24 +04:00
let memCategory = memberCategory m
withStore' ( \ db -> getViaGroupContact db vr user m ) >>= \ case
Nothing -> do
notifyMemberConnected gInfo m Nothing
let connectedIncognito = memberIncognito membership
2025-04-03 09:36:28 +00:00
when ( memCategory == GCPreMember ) $
2025-04-02 07:57:18 +00:00
probeMatchingMemberContact m connectedIncognito
2024-12-20 16:54:24 +04:00
Just ct @ Contact { activeConn } ->
forM_ activeConn $ \ Connection { connStatus } ->
when ( connStatus == ConnReady ) $ do
notifyMemberConnected gInfo m $ Just ct
let connectedIncognito = contactConnIncognito ct || incognitoMembership gInfo
2025-04-02 07:57:18 +00:00
when ( memCategory == GCPreMember && not ( memberPending membership ) ) $
probeMatchingContactsAndMembers ct connectedIncognito True
2024-12-20 16:54:24 +04:00
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
2025-04-02 07:57:18 +00:00
-- possible improvement is to choose scope based on event (some events specify scope)
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-04-02 07:57:18 +00:00
checkIntegrityCreateItem ( CDGroupRcv gInfo' scopeInfo m' ) msgMeta ` catchChatError ` \ _ -> pure ()
2024-12-20 16:54:24 +04:00
forM_ aChatMsgs $ \ case
Right ( ACMsg _ chatMsg ) ->
2025-05-05 12:53:05 +01:00
processEvent gInfo' m' tags eInfo chatMsg ` catchChatError ` \ e -> eToView e
2024-12-20 16:54:24 +04:00
Left e -> do
atomically $ modifyTVar' tags ( " error " : )
logInfo $ " group msg=error " <> eInfo <> " " <> tshow e
2025-05-05 11:51:22 +01:00
eToView ( ChatError . CEException $ " error parsing chat message: " <> e )
forwardMsgs ( rights aChatMsgs ) ` catchChatError ` eToView
2024-12-20 16:54:24 +04:00
checkSendRcpt $ rights aChatMsgs
where
aChatMsgs = parseChatMessages msgBody
brokerTs = metaBrokerTs msgMeta
2025-04-02 07:57:18 +00:00
processEvent :: GroupInfo -> GroupMember -> TVar [ Text ] -> Text -> MsgEncodingI e => ChatMessage e -> CM ()
processEvent gInfo' m' tags eInfo chatMsg @ ChatMessage { chatMsgEvent } = do
2024-12-20 16:54:24 +04:00
let tag = toCMEventTag chatMsgEvent
atomically $ modifyTVar' tags ( tshow tag : )
logInfo $ " group msg= " <> tshow tag <> " " <> eInfo
2025-04-02 07:57:18 +00:00
( m'' , conn' , msg @ RcvMessage { chatMsgEvent = ACME _ event } ) <- saveGroupRcvMsg user groupId m' conn msgMeta msgBody chatMsg
2024-12-20 16:54:24 +04:00
case event of
2025-05-19 11:14:43 +01:00
XMsgNew mc -> memberCanSend m'' scope $ newGroupContentMessage gInfo' m'' mc msg brokerTs False
where ExtMsgContent { scope } = mcExtMsgContent mc
-- file description is always allowed, to allow sending files to support scope
XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo' m'' sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend m'' msgScope $ groupMessageUpdate gInfo' m'' sharedMsgId mContent mentions msgScope msg brokerTs ttl live
2025-04-02 07:57:18 +00:00
XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo' m'' sharedMsgId memberId msg brokerTs
XMsgReact sharedMsgId ( Just memberId ) reaction add -> groupMsgReaction gInfo' m'' sharedMsgId memberId reaction add msg brokerTs
2024-12-20 16:54:24 +04:00
-- TODO discontinue XFile
2025-04-02 07:57:18 +00:00
XFile fInv -> processGroupFileInvitation' gInfo' m'' fInv msg brokerTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo' m'' sharedMsgId
XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInvGroup gInfo' m'' sharedMsgId fileConnReq_ fName
XInfo p -> xInfoMember gInfo' m'' p brokerTs
XGrpLinkMem p -> xGrpLinkMem gInfo' m'' conn' p
2025-04-28 06:28:40 +00:00
XGrpLinkAcpt acceptance role memberId -> xGrpLinkAcpt gInfo' m'' acceptance role memberId msg brokerTs
2025-04-02 07:57:18 +00:00
XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo' m'' memInfo msgScope msg brokerTs
XGrpMemIntro memInfo memRestrictions_ -> xGrpMemIntro gInfo' m'' memInfo memRestrictions_
XGrpMemInv memId introInv -> xGrpMemInv gInfo' m'' memId introInv
XGrpMemFwd memInfo introInv -> xGrpMemFwd gInfo' m'' memInfo introInv
XGrpMemRole memId memRole -> xGrpMemRole gInfo' m'' memId memRole msg brokerTs
XGrpMemRestrict memId memRestrictions -> xGrpMemRestrict gInfo' m'' memId memRestrictions msg brokerTs
XGrpMemCon memId -> xGrpMemCon gInfo' m'' memId
XGrpMemDel memId withMessages -> xGrpMemDel gInfo' m'' memId withMessages msg brokerTs
XGrpLeave -> xGrpLeave gInfo' m'' msg brokerTs
XGrpDel -> xGrpDel gInfo' m'' msg brokerTs
XGrpInfo p' -> xGrpInfo gInfo' m'' p' msg brokerTs
XGrpPrefs ps' -> xGrpPrefs gInfo' m'' ps'
2025-05-19 11:14:43 +01:00
-- TODO [knocking] why don't we forward these messages?
XGrpDirectInv connReq mContent_ msgScope -> memberCanSend m'' msgScope $ xGrpDirectInv gInfo' m'' conn' connReq mContent_ msg brokerTs
2025-04-02 07:57:18 +00:00
XGrpMsgForward memberId msg' msgTs -> xGrpMsgForward gInfo' m'' memberId msg' msgTs
XInfoProbe probe -> xInfoProbe ( COMGroupMember m'' ) probe
XInfoProbeCheck probeHash -> xInfoProbeCheck ( COMGroupMember m'' ) probeHash
XInfoProbeOk probe -> xInfoProbeOk ( COMGroupMember m'' ) probe
BFileChunk sharedMsgId chunk -> bFileChunkGroup gInfo' sharedMsgId chunk msgMeta
2024-12-20 16:54:24 +04:00
_ -> messageError $ " unsupported message: " <> tshow event
checkSendRcpt :: [ AChatMessage ] -> CM Bool
checkSendRcpt aMsgs = do
currentMemCount <- withStore' $ \ db -> getGroupCurrentMembersCount db user gInfo
let GroupInfo { chatSettings = ChatSettings { sendRcpts } } = gInfo
pure $
fromMaybe ( sendRcptsSmallGroups user ) sendRcpts
&& any aChatMsgHasReceipt aMsgs
&& currentMemCount <= smallGroupsRcptsMemLimit
where
aChatMsgHasReceipt ( ACMsg _ ChatMessage { chatMsgEvent } ) =
hasDeliveryReceipt ( toCMEventTag chatMsgEvent )
forwardMsgs :: [ AChatMessage ] -> CM ()
forwardMsgs aMsgs = do
2025-04-02 07:57:18 +00:00
-- TODO [knocking] forward to/from GSMemPendingReview members
2024-12-20 16:54:24 +04:00
let GroupMember { memberRole = membershipMemRole } = membership
when ( membershipMemRole >= GRAdmin && not ( blockedByAdmin m ) ) $ do
let forwardedMsgs = mapMaybe ( \ ( ACMsg _ chatMsg ) -> forwardedGroupMsg chatMsg ) aMsgs
forM_ ( L . nonEmpty forwardedMsgs ) $ \ forwardedMsgs' -> do
ChatConfig { highlyAvailable } <- asks config
-- members introduced to this invited member
introducedMembers <-
if memberCategory m == GCInviteeMember
then withStore' $ \ db -> getForwardIntroducedMembers db vr user m highlyAvailable
else pure []
-- invited members to which this member was introduced
invitedMembers <- withStore' $ \ db -> getForwardInvitedMembers db vr user m highlyAvailable
let GroupMember { memberId } = m
ms = forwardedToGroupMembers ( introducedMembers <> invitedMembers ) forwardedMsgs'
events = L . map ( \ cm -> XGrpMsgForward memberId cm brokerTs ) forwardedMsgs'
2025-04-02 07:57:18 +00:00
unless ( null ms ) $ void $ sendGroupMessages_ user gInfo ms events
2024-12-20 16:54:24 +04:00
RCVD msgMeta msgRcpt ->
withAckMessage' " group rcvd " agentConnId msgMeta $
groupMsgReceived gInfo m conn msgMeta msgRcpt
SENT msgId proxy -> do
continued <- continueSending connEntity conn
sentMsgDeliveryEvent conn msgId
checkSndInlineFTComplete conn msgId
updateGroupItemsStatus gInfo m conn msgId GSSSent ( Just $ isJust proxy )
when continued $ sendPendingGroupMessages user m conn
SWITCH qd phase cStats -> do
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupMemberSwitch user gInfo m ( SwitchProgress qd phase cStats )
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2024-12-20 16:54:24 +04:00
when ( phase == SPStarted || phase == SPCompleted ) $ case qd of
2025-04-02 07:57:18 +00:00
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
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2024-12-20 16:54:24 +04:00
case ( rss , connectionCode , cryptoErr_ ) of
2025-04-02 07:57:18 +00:00
( RSRequired , _ , Just cryptoErr ) -> processErr gInfo' scopeInfo m' cryptoErr
( RSAllowed , _ , Just cryptoErr ) -> processErr gInfo' scopeInfo m' cryptoErr
2024-12-20 16:54:24 +04:00
( RSAgreed , Just _ , _ ) -> do
withStore' $ \ db -> setConnectionVerified db user connId Nothing
2025-04-02 07:57:18 +00:00
let m'' = m' { activeConn = Just ( conn { connectionCode = Nothing } :: Connection ) } :: GroupMember
ratchetSyncEventItem gInfo' scopeInfo m''
2025-05-04 23:25:50 +01:00
toViewTE $ TEGroupMemberVerificationReset user gInfo' m''
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo' scopeInfo m'' ) ( CIRcvConnEvent RCEVerificationCodeReset ) Nothing
_ -> ratchetSyncEventItem gInfo' scopeInfo m'
2024-12-20 16:54:24 +04:00
where
2025-04-02 07:57:18 +00:00
processErr gInfo' scopeInfo m' cryptoErr = do
2024-12-20 16:54:24 +04:00
let e @ ( mde , n ) = agentMsgDecryptError cryptoErr
ci_ <- withStore $ \ db ->
2025-04-02 07:57:18 +00:00
getGroupMemberChatItemLast db user groupId ( groupMemberId' m' )
2024-12-20 16:54:24 +04:00
>>= liftIO
. mapM ( \ ( ci , content' ) -> updateGroupChatItem db user groupId ci content' False False Nothing )
. mdeUpdatedCI e
case ci_ of
2025-05-04 23:25:50 +01:00
Just ci -> toView $ CEvtChatItemUpdated user ( AChatItem SCTGroup SMDRcv ( GroupChat gInfo' scopeInfo ) ci )
2024-12-20 16:54:24 +04:00
_ -> do
2025-05-04 23:25:50 +01:00
toView $ CEvtGroupMemberRatchetSync user gInfo' m' ( RatchetSyncProgress rss cStats )
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo' scopeInfo m' ) ( CIRcvDecryptionError mde n ) Nothing
ratchetSyncEventItem gInfo' scopeInfo m' = do
2025-05-04 23:25:50 +01:00
toView $ CEvtGroupMemberRatchetSync user gInfo' m' ( RatchetSyncProgress rss cStats )
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo' scopeInfo m' ) ( CIRcvConnEvent $ RCERatchetSync rss ) Nothing
2024-12-20 16:54:24 +04:00
OK ->
-- [async agent commands] continuation on receiving OK
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
JOINED sqSecured _serviceId ->
2024-12-20 16:54:24 +04:00
-- [async agent commands] continuation on receiving JOINED
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData ->
when ( sqSecured && connChatVersion >= batchSend2Version ) sendGroupAutoReply
QCONT -> do
continued <- continueSending connEntity conn
when continued $ sendPendingGroupMessages user m conn
MWARN msgId err -> do
withStore' $ \ db -> updateGroupItemsErrorStatus db msgId ( groupMemberId' m ) ( GSSWarning $ agentSndError err )
processConnMWARN connEntity conn err
MERR msgId err -> do
withStore' $ \ db -> updateGroupItemsErrorStatus db msgId ( groupMemberId' m ) ( GSSError $ agentSndError err )
-- group errors are silenced to reduce load on UI event log
2025-05-05 11:51:22 +01:00
-- eToView (ChatErrorAgent err $ Just connEntity)
2024-12-20 16:54:24 +04:00
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 ()
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
where
updateGroupItemsErrorStatus :: DB . Connection -> AgentMsgId -> GroupMemberId -> GroupSndStatus -> IO ()
updateGroupItemsErrorStatus db msgId groupMemberId newStatus = do
itemIds <- getChatItemIdsByAgentMsgId db connId msgId
forM_ itemIds $ \ itemId -> updateGroupMemSndStatus' db itemId groupMemberId newStatus
sendGroupAutoReply = autoReplyMC >>= mapM_ send
where
autoReplyMC = do
let GroupInfo { businessChat } = gInfo
GroupMember { memberId = joiningMemberId } = m
case businessChat of
Just BusinessChatInfo { customerId , chatType = BCCustomer }
| joiningMemberId == customerId -> useReply <$> withStore ( ` getUserAddress ` user )
where
2025-06-23 14:42:00 +01:00
useReply UserContactLink { addressSettings = AddressSettings { autoReply } } = autoReply
2024-12-20 16:54:24 +04:00
_ -> pure Nothing
send mc = do
msg <- sendGroupMessage' user gInfo [ m ] ( XMsgNew $ MCSimple ( extMsgContent mc Nothing ) )
2025-04-02 07:57:18 +00:00
ci <- saveSndChatItem user ( CDGroupSnd gInfo Nothing ) msg ( CISndMsgContent mc )
2024-12-20 16:54:24 +04:00
withStore' $ \ db -> createGroupSndStatus db ( chatItemId' ci ) ( groupMemberId' m ) GSSNew
2025-05-04 23:25:50 +01:00
toView $ CEvtNewChatItems user [ AChatItem SCTGroup SMDSnd ( GroupChat gInfo Nothing ) ci ]
2024-12-20 16:54:24 +04:00
agentMsgDecryptError :: AgentCryptoError -> ( MsgDecryptError , Word32 )
agentMsgDecryptError = \ case
DECRYPT_AES -> ( MDEOther , 1 )
DECRYPT_CB -> ( MDEOther , 1 )
RATCHET_HEADER -> ( MDERatchetHeader , 1 )
RATCHET_EARLIER _ -> ( MDERatchetEarlier , 1 )
RATCHET_SKIPPED n -> ( MDETooManySkipped , n )
RATCHET_SYNC -> ( MDERatchetSync , 0 )
mdeUpdatedCI :: ( MsgDecryptError , Word32 ) -> CChatItem c -> Maybe ( ChatItem c 'MDRcv , CIContent 'MDRcv )
mdeUpdatedCI ( mde' , n' ) ( CChatItem _ ci @ ChatItem { content = CIRcvDecryptionError mde n } )
| mde == mde' = case mde of
MDERatchetHeader -> r ( n + n' )
MDETooManySkipped -> r n' -- the numbers are not added as sequential MDETooManySkipped will have it incremented by 1
MDERatchetEarlier -> r ( n + n' )
MDEOther -> r ( n + n' )
MDERatchetSync -> r 0
| otherwise = Nothing
where
r n'' = Just ( ci , CIRcvDecryptionError mde n'' )
mdeUpdatedCI _ _ = Nothing
processSndFileConn :: AEvent e -> ConnectionEntity -> Connection -> SndFileTransfer -> CM ()
processSndFileConn agentMsg connEntity conn ft @ SndFileTransfer { fileId , fileName , fileStatus } =
case agentMsg of
-- SMP CONF for SndFileConnection happens for direct file protocol
-- when recipient of the file "joins" connection created by the sender
CONF confId _pqSupport _ connInfo -> do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn connInfo
conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of
-- TODO save XFileAcpt message
XFileAcpt name
| name == fileName -> do
withStore' $ \ db -> updateSndFileStatus db ft FSAccepted
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
allowAgentConnectionAsync user conn' confId XOk
| otherwise -> messageError " x.file.acpt: fileName is different from expected "
_ -> messageError " CONF from file connection must have x.file.acpt "
CON _ -> do
ci <- withStore $ \ db -> do
liftIO $ updateSndFileStatus db ft FSConnected
updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileStart user ci ft
2024-12-20 16:54:24 +04:00
sendFileChunk user ft
SENT msgId _proxy -> do
withStore' $ \ db -> updateSndFileChunkSent db ft msgId
unless ( fileStatus == FSCancelled ) $ sendFileChunk user ft
MERR _ err -> do
2025-05-05 11:51:22 +01:00
cancelSndFileTransfer user ft True >>= mapM_ deleteAgentConnectionAsync
2024-12-20 16:54:24 +04:00
case err of
SMP _ SMP . AUTH -> unless ( fileStatus == FSCancelled ) $ do
ci <- withStore $ \ db -> do
liftIO ( lookupChatRefByFileId db user fileId ) >>= \ case
2025-04-02 07:57:18 +00:00
Just ( ChatRef CTDirect _ _ ) -> liftIO $ updateFileCancelled db user fileId CIFSSndCancelled
2024-12-20 16:54:24 +04:00
_ -> pure ()
lookupChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileRcvCancelled user ci ft
2024-12-20 16:54:24 +04:00
_ -> throwChatError $ CEFileSend fileId err
MSG meta _ _ ->
withAckMessage' " file msg " agentConnId meta $ pure ()
OK ->
-- [async agent commands] continuation on receiving OK
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
JOINED _ _serviceId ->
2024-12-20 16:54:24 +04:00
-- [async agent commands] continuation on receiving JOINED
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
processRcvFileConn :: AEvent e -> ConnectionEntity -> Connection -> RcvFileTransfer -> CM ()
processRcvFileConn agentMsg connEntity conn ft @ RcvFileTransfer { fileId , fileInvitation = FileInvitation { fileName } , grpMemberId } =
case agentMsg of
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
INV ( ACR _ cReq ) _serviceId ->
2024-12-20 16:54:24 +04:00
withCompletedCommand conn agentMsg $ \ CommandData { cmdFunction } ->
case cReq of
fileInvConnReq @ ( CRInvitationUri _ _ ) -> case cmdFunction of
-- [async agent commands] direct XFileAcptInv continuation on receiving INV
CFCreateConnFileInvDirect -> do
ct <- withStore $ \ db -> getContactByFileId db vr user fileId
sharedMsgId <- withStore $ \ db -> getSharedMsgIdByFileId db userId fileId
void $ sendDirectContactMessage user ct ( XFileAcptInv sharedMsgId ( Just fileInvConnReq ) fileName )
-- [async agent commands] group XFileAcptInv continuation on receiving INV
CFCreateConnFileInvGroup -> case grpMemberId of
Just gMemberId -> do
GroupMember { groupId , activeConn } <- withStore $ \ db -> getGroupMemberById db vr user gMemberId
case activeConn of
Just gMemberConn -> do
sharedMsgId <- withStore $ \ db -> getSharedMsgIdByFileId db userId fileId
void $ sendDirectMemberMessage gMemberConn ( XFileAcptInv sharedMsgId ( Just fileInvConnReq ) fileName ) groupId
_ -> throwChatError $ CECommandError " no GroupMember activeConn "
_ -> throwChatError $ CECommandError " no grpMemberId "
_ -> throwChatError $ CECommandError " unexpected cmdFunction "
CRContactUri _ -> throwChatError $ CECommandError " unexpected ConnectionRequestUri type "
-- SMP CONF for RcvFileConnection happens for group file protocol
-- when sender of the file "joins" connection created by the recipient
-- (sender doesn't create connections for all group members)
CONF confId _pqSupport _ connInfo -> do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn connInfo
conn' <- updatePeerChatVRange conn chatVRange
case chatMsgEvent of
XOk -> allowAgentConnectionAsync user conn' confId XOk -- [async agent commands] no continuation needed, but command should be asynchronous for stability
_ -> pure ()
CON _ -> startReceivingFile user fileId
MSG meta _ msgBody -> do
-- XXX: not all branches do ACK
parseFileChunk msgBody >>= receiveFileChunk ft ( Just conn ) meta
OK ->
-- [async agent commands] continuation on receiving OK
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
2025-06-09 18:23:53 +01:00
-- TODO [certs rcv]
JOINED _ _serviceId ->
2024-12-20 16:54:24 +04:00
-- [async agent commands] continuation on receiving JOINED
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
MERR _ err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
processConnMERR connEntity conn err
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
receiveFileChunk :: RcvFileTransfer -> Maybe Connection -> MsgMeta -> FileChunk -> CM ()
receiveFileChunk ft @ RcvFileTransfer { fileId , chunkSize } conn_ meta @ MsgMeta { recipient = ( msgId , _ ) , integrity } = \ case
FileChunkCancel ->
unless ( rcvFileCompleteOrCancelled ft ) $ do
2025-05-05 11:51:22 +01:00
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
2024-12-20 16:54:24 +04:00
ci <- withStore $ \ db -> getChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileSndCancelled user ci ft
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileComplete user ci
2025-05-05 11:51:22 +01:00
mapM_ ( deleteAgentConnectionAsync . aConnId ) conn_
2024-12-20 16:54:24 +04:00
RcvChunkDuplicate -> withAckMessage' " file msg " agentConnId meta $ pure ()
RcvChunkError -> badRcvFileChunk ft $ " incorrect chunk number " <> show chunkNo
processUserContactRequest :: AEvent e -> ConnectionEntity -> Connection -> UserContact -> CM ()
2025-06-09 16:18:01 +00:00
processUserContactRequest agentMsg connEntity conn UserContact { userContactLinkId = uclId } = case agentMsg of
2024-12-20 16:54:24 +04:00
REQ invId pqSupport _ connInfo -> do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage conn connInfo
case chatMsgEvent of
2025-06-23 14:42:00 +01:00
XContact p xContactId_ welcomeMsgId_ requestMsg_ -> profileContactRequest invId chatVRange p xContactId_ welcomeMsgId_ requestMsg_ pqSupport
XInfo p -> profileContactRequest invId chatVRange p Nothing Nothing Nothing pqSupport
2024-12-20 16:54:24 +04:00
-- TODO show/log error, other events in contact request
_ -> pure ()
MERR _ err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
processConnMERR connEntity conn err
ERR err -> do
2025-05-05 11:51:22 +01:00
eToView ( ChatErrorAgent err $ Just connEntity )
2024-12-20 16:54:24 +04:00
when ( corrId /= " " ) $ withCompletedCommand conn agentMsg $ \ _cmdData -> pure ()
-- TODO add debugging output
_ -> pure ()
where
2025-06-23 14:42:00 +01:00
profileContactRequest :: InvitationId -> VersionRangeChat -> Profile -> Maybe XContactId -> Maybe SharedMsgId -> Maybe ( SharedMsgId , MsgContent ) -> PQSupport -> CM ()
profileContactRequest invId chatVRange p @ Profile { displayName } xContactId_ welcomeMsgId_ requestMsg_ reqPQSup = do
2025-06-25 19:34:34 +04:00
( 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 ->
2025-06-25 18:04:33 +04:00
-- TODO update request msg
2025-06-25 19:34:34 +04:00
toView $ CEvtContactRequestAlreadyAccepted user ct
REBusinessChat gInfo _clientMember ->
-- TODO update request msg
toView $ CEvtBusinessRequestAlreadyAccepted user gInfo
RSCurrentRequest ucr re_ repeatRequest -> case re_ of
Nothing -> toView $ CEvtReceivedContactRequest user ucr Nothing
Just ( REContact ct ) -> do
-- TODO [short links] prevent duplicate items
-- update welcome message if changed (send update event to UI) and add updated feature items.
-- Do not created e2e item on repeat request
if repeatRequest
then do
-- TODO update request msg
-- ....
acceptOrShow Nothing -- pass item?
else do
-- TODO [short links] save sharedMsgId instead of the last Nothing
let createItem content = createChatItem user ( CDDirectRcv ct ) False content Nothing Nothing
void $ createItem $ CIRcvDirectE2EEInfo $ E2EInfo $ Just $ CR . pqSupportToEnc $ reqPQSup
void $ createFeatureEnabledItems_ user ct
-- TODO [short links] save sharedMsgId
aci <- forM requestMsg_ $ \ ( sharedMsgId , mc ) -> do
aci <- createItem $ CIRcvMsgContent mc
unlessM ( asks $ coreApi . config ) $ toView $ CEvtNewChatItems user [ aci ]
pure aci
acceptOrShow aci
where
acceptOrShow aci_ =
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
-- chat in event?
toView $ CEvtAcceptingContactRequest user ct'
Just ( REBusinessChat gInfo clientMember ) -> do
-- TODO [short links] prevent duplicate items (use repeatRequest like for REContact)
( _gInfo' , _clientMember' ) <- acceptBusinessJoinRequestAsync user uclId gInfo clientMember ucr
-- TODO [short links] add welcome message if welcomeMsgId is present
-- forM_ autoReply $ \arMC ->
-- when (shortLinkDataSet && v >= shortLinkDataVersion) $
-- createInternalChatItem user (CDGroupSnd gInfo Nothing) (CISndMsgContent arMC) Nothing
2025-06-25 18:04:33 +04:00
-- TODO [short links] save sharedMsgId
2025-06-25 19:34:34 +04:00
forM_ requestMsg_ $ \ ( sharedMsgId , mc ) ->
createInternalChatItem user ( CDGroupRcv gInfo Nothing clientMember ) ( CIRcvMsgContent mc ) Nothing
toView $ CEvtAcceptingBusinessRequest user gInfo
-- ##### Group link join requests #####
Just gli @ GroupLinkInfo { groupId , memberRole = gLinkMemRole } -> do
-- TODO deduplicate request by xContactId?
gInfo <- withStore $ \ db -> getGroupInfo db vr user groupId
acceptMember_ <- asks $ acceptMember . chatHooks . config
maybe ( pure $ Right ( GAAccepted , gLinkMemRole ) ) ( \ am -> liftIO $ am gInfo gli p ) acceptMember_ >>= \ case
Right ( acceptance , useRole )
| v < groupFastLinkJoinVersion ->
messageError " processUserContactRequest: 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_ acceptance useRole profileMode
( 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 $ " processUserContactRequest (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
2024-12-20 16:54:24 +04:00
2025-05-19 11:14:43 +01:00
memberCanSend :: GroupMember -> Maybe MsgScope -> CM () -> CM ()
memberCanSend 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 "
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtContactDisabled user ct { activeConn = Just ctConn { authErrCounter = authErrCounter' } }
_ -> toView $ CEvtConnectionDisabled connEntity
2024-12-20 16:54:24 +04:00
SMP _ SMP . QUOTA ->
unless ( connInactive conn ) $ do
withStore' $ \ db -> setQuotaErrCounter db user conn quotaErrSetOnMERR
2025-05-04 22:14:36 +01:00
toView $ CEvtConnectionInactive connEntity True
2024-12-20 16:54:24 +04:00
_ -> 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 ) $
2025-05-04 22:14:36 +01:00
toView $ CEvtConnectionInactive connEntity True
2024-12-20 16:54:24 +04:00
_ -> pure ()
continueSending :: ConnectionEntity -> Connection -> CM Bool
continueSending connEntity conn =
if connInactive conn
then do
withStore' $ \ db -> setQuotaErrCounter db user conn 0
2025-05-04 22:14:36 +01:00
toView $ CEvtConnectionInactive connEntity False
2024-12-20 16:54:24 +04:00
pure True
else pure False
-- TODO v5.7 / v6.0 - together with deprecating old group protocol establishing direct connections?
-- we could save command records only for agent APIs we process continuations for (INV)
withCompletedCommand :: forall e . AEntityI e => Connection -> AEvent e -> ( CommandData -> CM () ) -> CM ()
withCompletedCommand Connection { connId } agentMsg action = do
let agentMsgTag = AEvtTag ( sAEntity @ e ) $ aEventTag agentMsg
cmdData_ <- withStore' $ \ db -> getCommandDataByCorrId db user corrId
case cmdData_ of
Just cmdData @ CommandData { cmdId , cmdConnId = Just cmdConnId' , cmdFunction }
| connId == cmdConnId' && ( agentMsgTag == commandExpectedResponse cmdFunction || agentMsgTag == AEvtTag SAEConn ERR_ ) -> do
withStore' $ \ db -> deleteCommand db user cmdId
action cmdData
| otherwise -> err cmdId $ " not matching connection id or unexpected response, corrId = " <> show corrId
Just CommandData { cmdId , cmdConnId = Nothing } -> err cmdId $ " no command connection id, corrId = " <> show corrId
Nothing -> throwChatError . CEAgentCommandError $ " command not found, corrId = " <> show corrId
where
err cmdId msg = do
withStore' $ \ db -> updateCommandStatus db user cmdId CSError
throwChatError . CEAgentCommandError $ msg
withAckMessage' :: Text -> ConnId -> MsgMeta -> CM () -> CM ()
withAckMessage' label cId msgMeta action = do
withAckMessage label cId msgMeta False Nothing $ \ _ -> action $> False
withAckMessage :: Text -> ConnId -> MsgMeta -> Bool -> Maybe ( TVar [ Text ] ) -> ( Text -> CM Bool ) -> CM ()
withAckMessage label cId msgMeta showCritical tags action = do
-- [async agent commands] command should be asynchronous
-- TODO catching error and sending ACK after an error, particularly if it is a database error, will result in the message not processed (and no notification to the user).
-- Possible solutions are:
-- 1) retry processing several times
-- 2) stabilize database
-- 3) show screen of death to the user asking to restart
eInfo <- eventInfo
logInfo $ label <> " : " <> eInfo
tryChatError ( action eInfo ) >>= \ case
Right withRcpt ->
withLog ( eInfo <> " ok " ) $ ackMsg msgMeta $ if withRcpt then Just " " else Nothing
-- If showCritical is True, then these errors don't result in ACK and show user visible alert
-- This prevents losing the message that failed to be processed.
Left ( ChatErrorStore SEDBBusyError { message } ) | showCritical -> throwError $ ChatErrorAgent ( CRITICAL True message ) Nothing
Left e -> do
withLog ( eInfo <> " error: " <> tshow e ) $ ackMsg msgMeta Nothing
throwError e
where
eventInfo = do
v <- asks eventSeq
eId <- atomically $ stateTVar v $ \ i -> ( i + 1 , i + 1 )
pure $ " conn_id= " <> tshow cId <> " event_id= " <> tshow eId
withLog eInfo' ack = do
ts <- showTags
logInfo $ T . unwords [ label , " ack: " , ts , eInfo' ]
ack
logInfo $ T . unwords [ label , " ack=success: " , ts , eInfo' ]
showTags = do
ts <- maybe ( pure [] ) readTVarIO tags
pure $ case ts of
[] -> " no_chat_messages "
[ t ] -> " chat_message= " <> t
_ -> " chat_message_batch= " <> T . intercalate " , " ( reverse ts )
ackMsg :: MsgMeta -> Maybe MsgReceiptInfo -> CM ()
ackMsg MsgMeta { recipient = ( msgId , _ ) } rcpt = withAgent $ \ a -> ackMessageAsync a " " cId msgId rcpt
sentMsgDeliveryEvent :: Connection -> AgentMsgId -> CM ()
sentMsgDeliveryEvent Connection { connId } msgId =
withStore' $ \ db -> updateSndMsgDeliveryStatus db connId msgId MDSSndSent
agentSndError :: AgentErrorType -> SndError
agentSndError = \ case
SMP _ AUTH -> SndErrAuth
SMP _ QUOTA -> SndErrQuota
BROKER _ e -> brokerError SndErrRelay e
SMP proxySrv ( SMP . PROXY ( SMP . BROKER e ) ) -> brokerError ( SndErrProxy proxySrv ) e
AP . PROXY proxySrv _ ( ProxyProtocolError ( SMP . PROXY ( SMP . BROKER e ) ) ) -> brokerError ( SndErrProxyRelay proxySrv ) e
e -> SndErrOther $ tshow e
where
brokerError srvErr = \ case
NETWORK -> SndErrExpired
TIMEOUT -> SndErrExpired
HOST -> srvErr SrvErrHost
SMP . TRANSPORT TEVersion -> srvErr SrvErrVersion
e -> srvErr . SrvErrOther $ tshow e
badRcvFileChunk :: RcvFileTransfer -> String -> CM ()
badRcvFileChunk ft err =
unless ( rcvFileCompleteOrCancelled ft ) $ do
2025-05-05 11:51:22 +01:00
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
2024-12-20 16:54:24 +04:00
throwChatError $ CEFileRcvChunk err
2025-04-02 07:57:18 +00:00
memberConnectedChatItem :: GroupInfo -> Maybe GroupChatScopeInfo -> GroupMember -> CM ()
memberConnectedChatItem gInfo scopeInfo m =
2024-12-20 16:54:24 +04:00
-- ts should be broker ts but we don't have it for CON
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo scopeInfo m ) ( CIRcvGroupEvent RGEMemberConnected ) Nothing
2024-12-20 16:54:24 +04:00
notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> CM ()
notifyMemberConnected gInfo m ct_ = do
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-04-02 07:57:18 +00:00
memberConnectedChatItem gInfo' scopeInfo m'
2024-12-20 16:54:24 +04:00
lift $ mapM_ ( ` setContactNetworkStatus ` NSConnected ) ct_
2025-05-04 23:25:50 +01:00
toView $ CEvtConnectedToGroupMember user gInfo' m' ct_
2024-12-20 16:54:24 +04:00
probeMatchingContactsAndMembers :: Contact -> IncognitoEnabled -> Bool -> CM ()
probeMatchingContactsAndMembers ct connectedIncognito doProbeContacts = do
gVar <- asks random
contactMerge <- readTVarIO =<< asks contactMergeEnabled
if contactMerge && not connectedIncognito
then do
( probe , probeId ) <- withStore $ \ db -> createSentProbe db gVar userId ( COMContact ct )
-- ! when making changes to probe-and-merge mechanism,
-- ! test scenario in which recipient receives probe after probe hashes (not covered in tests):
-- sendProbe -> sendProbeHashes (currently)
-- sendProbeHashes -> sendProbe (reversed - change order in code, may add delay)
sendProbe probe
cs <-
if doProbeContacts
then map COMContact <$> withStore' ( \ db -> getMatchingContacts db vr user ct )
else pure []
ms <- map COMGroupMember <$> withStore' ( \ db -> getMatchingMembers db vr user ct )
sendProbeHashes ( cs <> ms ) probe probeId
else sendProbe . Probe =<< liftIO ( encodedRandomBytes gVar 32 )
where
sendProbe :: Probe -> CM ()
sendProbe probe = void . sendDirectContactMessage user ct $ XInfoProbe probe
probeMatchingMemberContact :: GroupMember -> IncognitoEnabled -> CM ()
probeMatchingMemberContact GroupMember { activeConn = Nothing } _ = pure ()
probeMatchingMemberContact m @ GroupMember { groupId , activeConn = Just conn } connectedIncognito = do
gVar <- asks random
contactMerge <- readTVarIO =<< asks contactMergeEnabled
if contactMerge && not connectedIncognito
then do
( probe , probeId ) <- withStore $ \ db -> createSentProbe db gVar userId $ COMGroupMember m
sendProbe probe
cs <- map COMContact <$> withStore' ( \ db -> getMatchingMemberContacts db vr user m )
sendProbeHashes cs probe probeId
else sendProbe . Probe =<< liftIO ( encodedRandomBytes gVar 32 )
where
sendProbe :: Probe -> CM ()
sendProbe probe = void $ sendDirectMemberMessage conn ( XInfoProbe probe ) groupId
sendProbeHashes :: [ ContactOrMember ] -> Probe -> Int64 -> CM ()
sendProbeHashes cgms probe probeId =
forM_ cgms $ \ cgm -> sendProbeHash cgm ` catchChatError ` \ _ -> pure ()
where
probeHash = ProbeHash $ C . sha256Hash ( unProbe probe )
sendProbeHash :: ContactOrMember -> CM ()
sendProbeHash cgm @ ( COMContact c ) = do
void . sendDirectContactMessage user c $ XInfoProbeCheck probeHash
withStore' $ \ db -> createSentProbeHash db userId probeId cgm
sendProbeHash ( COMGroupMember GroupMember { activeConn = Nothing } ) = pure ()
sendProbeHash cgm @ ( COMGroupMember m @ GroupMember { groupId , activeConn = Just conn } ) =
when ( memberCurrent m ) $ do
void $ sendDirectMemberMessage conn ( XInfoProbeCheck probeHash ) groupId
withStore' $ \ db -> createSentProbeHash db userId probeId cgm
messageWarning :: Text -> CM ()
2025-05-04 22:14:36 +01:00
messageWarning = toView . CEvtMessageError user " warning "
2024-12-20 16:54:24 +04:00
messageError :: Text -> CM ()
2025-05-04 22:14:36 +01:00
messageError = toView . CEvtMessageError user " error "
2024-12-20 16:54:24 +04:00
newContentMessage :: Contact -> MsgContainer -> RcvMessage -> MsgMeta -> CM ()
2025-01-31 10:32:07 +04:00
newContentMessage ct mc msg @ RcvMessage { sharedMsgId_ } msgMeta = do
2025-04-02 07:57:18 +00:00
let ExtMsgContent content _ fInv_ _ _ _ = mcExtMsgContent mc
2024-12-20 16:54:24 +04:00
-- 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
2025-01-29 13:04:48 +00:00
void $ newChatItem ( ciContentNoParse $ CIRcvChatFeatureRejected CFVoice ) Nothing Nothing False
2024-12-20 16:54:24 +04:00
else do
2025-04-02 07:57:18 +00:00
let ExtMsgContent _ _ _ itemTTL live_ _ = mcExtMsgContent mc
2024-12-20 16:54:24 +04:00
timed_ = rcvContactCITimed ct itemTTL
live = fromMaybe False live_
file_ <- processFileInvitation fInv_ content $ \ db -> createRcvFileTransfer db userId ct
2025-01-29 13:04:48 +00:00
newChatItem ( CIRcvMsgContent content , msgContentTexts content ) ( snd <$> file_ ) timed_ live
2024-12-20 16:54:24 +04:00
autoAcceptFile file_
where
brokerTs = metaBrokerTs msgMeta
2025-01-29 13:04:48 +00:00
newChatItem content ciFile_ timed_ live = do
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDDirectRcv ct ) msg sharedMsgId_ brokerTs content ciFile_ timed_ live M . empty
2024-12-20 16:54:24 +04:00
reactions <- maybe ( pure [] ) ( \ sharedMsgId -> withStore' $ \ db -> getDirectCIReactions db ct sharedMsgId ) sharedMsgId_
2025-05-09 15:36:06 +00:00
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci { reactions } ]
2024-12-20 16:54:24 +04:00
autoAcceptFile :: Maybe ( RcvFileTransfer , CIFile 'MDRcv ) -> CM ()
autoAcceptFile = mapM_ $ \ ( ft , CIFile { fileSize } ) -> do
-- ! autoAcceptFileSize is only used in tests
ChatConfig { autoAcceptFileSize = sz } <- asks config
2025-05-04 22:14:36 +01:00
when ( sz > fileSize ) $ receiveFileEvt' user ft False Nothing Nothing >>= toView
2024-12-20 16:54:24 +04:00
messageFileDescription :: Contact -> SharedMsgId -> FileDescr -> CM ()
messageFileDescription ct @ Contact { contactId } sharedMsgId fileDescr = do
fileId <- withStore $ \ db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
processFDMessage ( CDDirectRcv ct ) sharedMsgId fileId fileDescr
groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> CM ()
groupMessageFileDescription g @ GroupInfo { groupId } m sharedMsgId fileDescr = do
fileId <- withStore $ \ db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
2025-04-02 07:57:18 +00:00
-- here scope we pass only affects how chat item is searched in getAChatItemBySharedMsgId, and it ignores scope
processFDMessage ( CDGroupRcv g Nothing m ) sharedMsgId fileId fileDescr
2024-12-20 16:54:24 +04:00
processFDMessage :: ChatTypeQuotable c => ChatDirection c 'MDRcv -> SharedMsgId -> FileTransferId -> FileDescr -> CM ()
processFDMessage cd sharedMsgId fileId fileDescr = do
ft <- withStore $ \ db -> getRcvFileTransfer db user fileId
unless ( rcvFileCompleteOrCancelled ft ) $ do
( rfd @ RcvFileDescr { fileDescrComplete } , ft' @ RcvFileTransfer { fileStatus , xftpRcvFile , cryptoArgs } ) <- withStore $ \ db -> do
rfd <- appendRcvFD db userId fileId fileDescr
-- reading second time in the same transaction as appending description
-- to prevent race condition with accept
ft' <- getRcvFileTransfer db user fileId
pure ( rfd , ft' )
when fileDescrComplete $ do
ci <- withStore $ \ db -> getAChatItemBySharedMsgId db user cd sharedMsgId
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileDescrReady user ci ft' rfd
2024-12-20 16:54:24 +04:00
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
2025-01-29 13:04:48 +00:00
ts = ciContentTexts content
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDDirectRcv ct ) msg ( Just sharedMsgId ) brokerTs ( content , ts ) Nothing timed_ live M . empty
2024-12-20 16:54:24 +04:00
ci' <- withStore' $ \ db -> do
createChatItemVersion db ( chatItemId' ci ) brokerTs mc
updateDirectChatItem' db user contactId ci content True live Nothing Nothing
2025-05-09 15:36:06 +00:00
toView $ CEvtChatItemUpdated user ( AChatItem SCTDirect SMDRcv cInfo ci' )
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtChatItemUpdated user ( AChatItem SCTDirect SMDRcv ( DirectChat ct ) ci' )
2025-04-02 07:57:18 +00:00
startUpdatedTimedItemThread user ( ChatRef CTDirect contactId Nothing ) ci ci'
2025-05-04 22:14:36 +01:00
else toView $ CEvtChatItemNotChanged user ( AChatItem SCTDirect SMDRcv ( DirectChat ct ) ci )
2024-12-20 16:54:24 +04:00
_ -> messageError " x.msg.update: contact attempted invalid message update "
messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM ()
messageDelete ct @ Contact { contactId } sharedMsgId _rcvMessage msgMeta = do
2025-05-04 22:14:36 +01:00
deleteRcvChatItem ` catchCINotFound ` ( toView . CEvtChatItemDeletedNotFound user ct )
2024-12-20 16:54:24 +04:00
where
brokerTs = metaBrokerTs msgMeta
deleteRcvChatItem = do
cci @ ( CChatItem msgDir ci ) <- withStore $ \ db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId
case msgDir of
SMDRcv
2025-05-04 22:14:36 +01:00
| 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
2024-12-20 16:54:24 +04:00
| 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
2025-05-04 22:14:36 +01:00
cEvt_ <- withStore $ \ db -> do
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
pure $ Just $ CEvtChatItemReaction user add r
2024-12-20 16:54:24 +04:00
else pure Nothing
2025-05-04 22:14:36 +01:00
mapM_ toView cEvt_
2024-12-20 16:54:24 +04:00
groupMsgReaction :: GroupInfo -> GroupMember -> SharedMsgId -> MemberId -> MsgReaction -> Bool -> RcvMessage -> UTCTime -> CM ()
2025-02-09 12:39:48 +00:00
groupMsgReaction g m sharedMsgId itemMemberId reaction add RcvMessage { msgId } brokerTs = do
2024-12-20 16:54:24 +04:00
when ( groupFeatureAllowed SGFReactions g ) $ do
rs <- withStore' $ \ db -> getGroupReactions db g m itemMemberId sharedMsgId False
when ( reactionAllowed add reaction rs ) $ do
updateChatItemReaction ` catchCINotFound ` \ _ ->
withStore' $ \ db -> setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
where
updateChatItemReaction = do
2025-05-04 22:14:36 +01:00
cEvt_ <- withStore $ \ db -> do
2025-02-09 12:39:48 +00:00
CChatItem md ci <- getGroupMemberCIBySharedMsgId db user g itemMemberId sharedMsgId
2025-04-02 07:57:18 +00:00
scopeInfo <- getGroupChatScopeInfoForItem db vr user g ( chatItemId' ci )
2024-12-20 16:54:24 +04:00
if ciReactionAllowed ci
then liftIO $ do
setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs
reactions <- getGroupCIReactions db g itemMemberId sharedMsgId
let ci' = CChatItem md ci { reactions }
2025-04-02 07:57:18 +00:00
r = ACIReaction SCTGroup SMDRcv ( GroupChat g scopeInfo ) $ CIReaction ( CIGroupRcv m ) ci' brokerTs reaction
2025-05-04 22:14:36 +01:00
pure $ Just $ CEvtChatItemReaction user add r
2024-12-20 16:54:24 +04:00
else pure Nothing
2025-05-04 22:14:36 +01:00
mapM_ toView cEvt_
2024-12-20 16:54:24 +04:00
reactionAllowed :: Bool -> MsgReaction -> [ MsgReaction ] -> Bool
reactionAllowed add reaction rs = ( reaction ` elem ` rs ) /= add && not ( add && length rs >= maxMsgReactions )
catchCINotFound :: CM a -> ( SharedMsgId -> CM a ) -> CM a
catchCINotFound f handle =
f ` catchChatError ` \ case
ChatErrorStore ( SEChatItemSharedMsgIdNotFound sharedMsgId ) -> handle sharedMsgId
e -> throwError e
newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> UTCTime -> Bool -> CM ()
2025-05-19 11:31:10 +00:00
newGroupContentMessage gInfo m @ GroupMember { memberId , memberRole } mc msg @ RcvMessage { sharedMsgId_ } brokerTs forwarded = do
( gInfo' , m' , scopeInfo ) <- mkGetMessageChatScope vr user gInfo m msgScope_
if blockedByAdmin m'
then createBlockedByAdmin gInfo' m' scopeInfo
else
case prohibitedGroupContent gInfo' m' scopeInfo content ft_ fInv_ False of
Just f -> rejected gInfo' m' scopeInfo f
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_
Nothing -> createContentItem gInfo' m' scopeInfo
2024-12-20 16:54:24 +04:00
where
2025-05-19 11:31:10 +00:00
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
2024-12-20 16:54:24 +04:00
live' = fromMaybe False live_
2025-04-02 07:57:18 +00:00
ExtMsgContent content mentions fInv_ itemTTL live_ msgScope_ = mcExtMsgContent mc
2025-01-29 13:04:48 +00:00
ts @ ( _ , ft_ ) = msgContentTexts content
2025-05-19 11:31:10 +00:00
saveRcvCI gInfo' m' scopeInfo = saveRcvChatItem' user ( CDGroupRcv gInfo' scopeInfo m' ) msg sharedMsgId_ brokerTs
createBlockedByAdmin gInfo' m' scopeInfo
| groupFeatureAllowed SGFFullDelete gInfo' = do
2025-01-31 10:32:07 +04:00
-- ignores member role when blocked by admin
2025-05-19 11:31:10 +00:00
( ci , cInfo ) <- saveRcvCI gInfo' m' scopeInfo ( ciContentNoParse CIRcvBlocked ) Nothing ( timed' gInfo' ) False M . empty
2025-04-02 07:57:18 +00:00
ci' <- withStore' $ \ db -> updateGroupCIBlockedByAdmin db user gInfo' ci brokerTs
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci'
2024-12-20 16:54:24 +04:00
| otherwise = do
2025-05-19 11:31:10 +00:00
file_ <- processFileInv m'
( ci , cInfo ) <- createNonLive gInfo' m' scopeInfo file_
ci' <- withStore' $ \ db -> markGroupCIBlockedByAdmin db user gInfo' ci
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci'
2025-05-19 11:31:10 +00:00
applyModeration gInfo' m' scopeInfo CIModeration { moderatorMember = moderator @ GroupMember { memberRole = moderatorRole } , moderatedAt }
2025-01-04 19:17:19 +00:00
| moderatorRole < GRModerator || moderatorRole < memberRole =
2025-05-19 11:31:10 +00:00
createContentItem gInfo' m' scopeInfo
| groupFeatureMemberAllowed SGFFullDelete moderator gInfo' = do
( ci , cInfo ) <- saveRcvCI gInfo' m' scopeInfo ( ciContentNoParse CIRcvModerated ) Nothing ( timed' gInfo' ) False M . empty
2025-04-02 07:57:18 +00:00
ci' <- withStore' $ \ db -> updateGroupChatItemModerated db user gInfo' ci moderator moderatedAt
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci'
2024-12-20 16:54:24 +04:00
| otherwise = do
2025-05-19 11:31:10 +00:00
file_ <- processFileInv m'
( ci , _cInfo ) <- createNonLive gInfo' m' scopeInfo file_
2025-05-04 23:25:50 +01:00
deletions <- markGroupCIsDeleted user gInfo' scopeInfo [ CChatItem SMDRcv ci ] ( Just moderator ) moderatedAt
2025-05-04 22:14:36 +01:00
toView $ CEvtChatItemsDeleted user deletions False False
2025-05-19 11:31:10 +00:00
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 m'
newChatItem gInfo' m' scopeInfo ( CIRcvMsgContent content , ts ) ( snd <$> file_ ) ( timed' gInfo' ) live'
when ( showMessages $ memberSettings m' ) $ autoAcceptFile file_
processFileInv m' =
processFileInvitation fInv_ content $ \ db -> createRcvGroupFileTransfer db userId m'
newChatItem gInfo' m' scopeInfo ciContent ciFile_ timed_ live = do
let mentions' = if showMessages ( memberSettings m' ) then mentions else []
( ci , cInfo ) <- saveRcvCI gInfo' m' scopeInfo ciContent ciFile_ timed_ live mentions'
2025-04-02 07:57:18 +00:00
ci' <- blockedMember m' ci $ withStore' $ \ db -> markGroupChatItemBlocked db user gInfo' ci
reactions <- maybe ( pure [] ) ( \ sharedMsgId -> withStore' $ \ db -> getGroupCIReactions db gInfo' memberId sharedMsgId ) sharedMsgId_
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci' { reactions }
2025-04-02 07:57:18 +00:00
groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> Map MemberName MsgMention -> Maybe MsgScope -> RcvMessage -> UTCTime -> Maybe Int -> Maybe Bool -> CM ()
groupMessageUpdate gInfo @ GroupInfo { groupId } m @ GroupMember { groupMemberId , memberId } sharedMsgId mc mentions msgScope_ msg @ RcvMessage { msgId } brokerTs ttl_ live_
2025-01-29 13:04:48 +00:00
| prohibitedSimplexLinks gInfo m ft_ =
2024-12-20 16:54:24 +04:00
messageWarning $ " x.msg.update ignored: feature not allowed " <> groupFeatureNameText GFSimplexLinks
| otherwise = do
updateRcvChatItem ` catchCINotFound ` \ _ -> do
-- This patches initial sharedMsgId into chat item when locally deleted chat item
-- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete).
-- Chat item and update message which created it will have different sharedMsgId in this case...
let timed_ = rcvGroupCITimed gInfo ttl_
2025-01-29 13:04:48 +00:00
mentions' = if showMessages ( memberSettings m ) then mentions else []
2025-04-02 07:57:18 +00:00
( gInfo' , m' , scopeInfo ) <- mkGetMessageChatScope vr user gInfo m msgScope_
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDGroupRcv gInfo' scopeInfo m' ) msg ( Just sharedMsgId ) brokerTs ( content , ts ) Nothing timed_ live mentions'
2024-12-20 16:54:24 +04:00
ci' <- withStore' $ \ db -> do
createChatItemVersion db ( chatItemId' ci ) brokerTs mc
ci' <- updateGroupChatItem db user groupId ci content True live Nothing
2025-04-02 07:57:18 +00:00
blockedMember m' ci' $ markGroupChatItemBlocked db user gInfo' ci'
2025-05-09 15:36:06 +00:00
toView $ CEvtChatItemUpdated user ( AChatItem SCTGroup SMDRcv cInfo ci' )
2024-12-20 16:54:24 +04:00
where
content = CIRcvMsgContent mc
2025-01-29 13:04:48 +00:00
ts @ ( _ , ft_ ) = msgContentTexts mc
2024-12-20 16:54:24 +04:00
live = fromMaybe False live_
updateRcvChatItem = do
2025-02-03 08:55:46 +00:00
cci <- withStore $ \ db -> getGroupChatItemBySharedMsgId db user gInfo groupMemberId sharedMsgId
2025-04-02 07:57:18 +00:00
scopeInfo <- withStore $ \ db -> getGroupChatScopeInfoForItem db vr user gInfo ( cChatItemId cci )
2024-12-20 16:54:24 +04:00
case cci of
CChatItem SMDRcv ci @ ChatItem { chatDir = CIGroupRcv m' , meta = CIMeta { itemLive } , content = CIRcvMsgContent oldMC } ->
if sameMemberId memberId m'
then do
let changed = mc /= oldMC
if changed || fromMaybe False itemLive
then do
ci' <- withStore' $ \ db -> do
when changed $
addInitialAndNewCIVersions db ( chatItemId' ci ) ( chatItemTs' ci , oldMC ) ( brokerTs , mc )
reactions <- getGroupCIReactions db gInfo memberId sharedMsgId
let edited = itemLive /= Just True
2025-01-30 10:06:26 +00:00
ciMentions <- getRcvCIMentions db user gInfo ft_ mentions
2025-01-29 13:04:48 +00:00
ci' <- updateGroupChatItem db user groupId ci { reactions } content edited live $ Just msgId
2025-01-30 10:06:26 +00:00
updateGroupCIMentions db gInfo ci' ciMentions
2025-05-04 23:25:50 +01:00
toView $ CEvtChatItemUpdated user ( AChatItem SCTGroup SMDRcv ( GroupChat gInfo scopeInfo ) ci' )
2025-04-02 07:57:18 +00:00
startUpdatedTimedItemThread user ( ChatRef CTGroup groupId $ toChatScope <$> scopeInfo ) ci ci'
2025-05-04 23:25:50 +01:00
else toView $ CEvtChatItemNotChanged user ( AChatItem SCTGroup SMDRcv ( GroupChat gInfo scopeInfo ) ci )
2024-12-20 16:54:24 +04:00
else messageError " x.msg.update: group member attempted to update a message of another member "
_ -> messageError " x.msg.update: group member attempted invalid message update "
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> UTCTime -> CM ()
2025-02-09 12:39:48 +00:00
groupMessageDelete gInfo @ GroupInfo { membership } m @ GroupMember { memberId , memberRole = senderRole } sharedMsgId sndMemberId_ RcvMessage { msgId } brokerTs = do
2024-12-20 16:54:24 +04:00
let msgMemberId = fromMaybe memberId sndMemberId_
2025-02-09 12:39:48 +00:00
withStore' ( \ db -> runExceptT $ getGroupMemberCIBySharedMsgId db user gInfo msgMemberId sharedMsgId ) >>= \ case
2024-12-20 16:54:24 +04:00
Right cci @ ( CChatItem _ ci @ ChatItem { chatDir } ) -> case chatDir of
CIGroupRcv mem -> case sndMemberId_ of
-- regular deletion
Nothing
| sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs ->
2025-05-04 22:14:36 +01:00
delete cci Nothing
2024-12-20 16:54:24 +04:00
| otherwise ->
messageError " x.msg.del: member attempted invalid message delete "
-- moderation (not limited by time)
Just _
| sameMemberId memberId mem && msgMemberId == memberId ->
2025-05-04 22:14:36 +01:00
delete cci ( Just m )
2024-12-20 16:54:24 +04:00
| otherwise ->
moderate mem cci
CIGroupSnd -> moderate membership cci
Left e
| msgMemberId == memberId -> messageError $ " x.msg.del: message not found, " <> tshow e
2025-01-04 19:17:19 +00:00
| senderRole < GRModerator -> messageError $ " x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e
2024-12-20 16:54:24 +04:00
| otherwise -> withStore' $ \ db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs
where
moderate :: GroupMember -> CChatItem 'CTGroup -> CM ()
moderate mem cci = case sndMemberId_ of
Just sndMemberId
2025-01-08 09:42:26 +00:00
| sameMemberId sndMemberId mem -> checkRole mem $ do
2025-05-04 22:14:36 +01:00
delete cci ( Just m )
2025-01-08 09:42:26 +00:00
archiveMessageReports cci m
2024-12-20 16:54:24 +04:00
| otherwise -> messageError " x.msg.del: message of another member with incorrect memberId "
_ -> messageError " x.msg.del: message of another member without memberId "
checkRole GroupMember { memberRole } a
2025-01-04 19:17:19 +00:00
| senderRole < GRModerator || senderRole < memberRole =
2024-12-20 16:54:24 +04:00
messageError " x.msg.del: message of another member with insufficient member permissions "
| otherwise = a
2025-05-04 22:14:36 +01:00
delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM ()
2025-04-02 07:57:18 +00:00
delete cci byGroupMember = do
scopeInfo <- withStore $ \ db -> getGroupChatScopeInfoForItem db vr user gInfo ( cChatItemId cci )
2025-05-04 22:14:36 +01:00
deletions <- if groupFeatureMemberAllowed SGFFullDelete m gInfo
2025-05-04 23:25:50 +01:00
then deleteGroupCIs user gInfo scopeInfo [ cci ] byGroupMember brokerTs
else markGroupCIsDeleted user gInfo scopeInfo [ cci ] byGroupMember brokerTs
2025-05-04 22:14:36 +01:00
toView $ CEvtChatItemsDeleted user deletions False False
2025-01-08 09:42:26 +00:00
archiveMessageReports :: CChatItem 'CTGroup -> GroupMember -> CM ()
archiveMessageReports ( CChatItem _ ci ) byMember = do
ciIds <- withStore' $ \ db -> markMessageReportsDeleted db user gInfo ci byMember brokerTs
2025-05-04 22:14:36 +01:00
unless ( null ciIds ) $ toView $ CEvtGroupChatItemsDeleted user gInfo ciIds False ( Just byMember )
2024-12-20 16:54:24 +04:00
-- 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 }
2025-01-29 13:04:48 +00:00
content = ciContentNoParse $ CIRcvMsgContent $ MCFile " "
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDDirectRcv ct ) msg sharedMsgId_ brokerTs content ciFile Nothing False M . empty
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2024-12-20 16:54:24 +04:00
where
brokerTs = metaBrokerTs msgMeta
-- TODO remove once XFile is discontinued
processGroupFileInvitation' :: GroupInfo -> GroupMember -> FileInvitation -> RcvMessage -> UTCTime -> CM ()
processGroupFileInvitation' gInfo m fInv @ FileInvitation { fileName , fileSize } msg @ RcvMessage { sharedMsgId_ } brokerTs = do
ChatConfig { fileChunkSize } <- asks config
inline <- receiveInlineMode fInv Nothing fileChunkSize
RcvFileTransfer { fileId , xftpRcvFile } <- withStore $ \ db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize
let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP
ciFile = Just $ CIFile { fileId , fileName , fileSize , fileSource = Nothing , fileStatus = CIFSRcvInvitation , fileProtocol }
2025-01-29 13:04:48 +00:00
content = ciContentNoParse $ CIRcvMsgContent $ MCFile " "
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDGroupRcv gInfo Nothing m ) msg sharedMsgId_ brokerTs content ciFile Nothing False M . empty
2024-12-20 16:54:24 +04:00
ci' <- blockedMember m ci $ withStore' $ \ db -> markGroupChatItemBlocked db user gInfo ci
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci'
2024-12-20 16:54:24 +04:00
blockedMember :: Monad m' => GroupMember -> ChatItem c d -> m' ( ChatItem c d ) -> m' ( ChatItem c d )
blockedMember m ci blockedCI
| showMessages ( memberSettings m ) = pure ci
| otherwise = blockedCI
receiveInlineMode :: FileInvitation -> Maybe MsgContent -> Integer -> CM ( Maybe InlineFileMode )
receiveInlineMode FileInvitation { fileSize , fileInline , fileDescr } mc_ chSize = case ( fileInline , fileDescr ) of
( Just mode , Nothing ) -> do
InlineFilesConfig { receiveChunks , receiveInstant } <- asks $ inlineFiles . config
pure $ if fileSize <= receiveChunks * chSize then inline' receiveInstant else Nothing
where
inline' receiveInstant = if mode == IFMOffer || ( receiveInstant && maybe False isVoice mc_ ) then fileInline else Nothing
_ -> pure Nothing
xFileCancel :: Contact -> SharedMsgId -> CM ()
xFileCancel Contact { contactId } sharedMsgId = do
fileId <- withStore $ \ db -> getFileIdBySharedMsgId db userId contactId sharedMsgId
ft <- withStore ( \ db -> getRcvFileTransfer db user fileId )
unless ( rcvFileCompleteOrCancelled ft ) $ do
2025-05-05 11:51:22 +01:00
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
2024-12-20 16:54:24 +04:00
ci <- withStore $ \ db -> getChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileSndCancelled user ci ft
2024-12-20 16:54:24 +04:00
xFileAcptInv :: Contact -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
xFileAcptInv ct sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \ db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId
( AChatItem _ _ _ ci ) <- withStore $ \ db -> getChatItemByFileId db vr user fileId
assertSMPAcceptNotProhibited ci
ft @ FileTransferMeta { fileName , fileSize , fileInline , cancelled } <- withStore ( \ db -> getFileTransferMeta db user fileId )
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
if fName == fileName
then unless cancelled $ case fileConnReq_ of
-- receiving via a separate connection
Just fileConnReq -> do
subMode <- chatReadVar subscriptionMode
dm <- encodeConnInfo XOk
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
withStore' $ \ db -> createSndDirectFTConnection db vr user fileId connIds subMode
-- receiving inline
_ -> do
event <- withStore $ \ db -> do
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- createSndDirectInlineFT db ct ft
2025-05-04 22:14:36 +01:00
pure $ CEvtSndFileStart user ci' sft
2024-12-20 16:54:24 +04:00
toView event
ifM
( allowSendInline fileSize fileInline )
( sendDirectFileInline user ct ft sharedMsgId )
( messageError " x.file.acpt.inv: fileSize is bigger than allowed to send inline " )
else messageError " x.file.acpt.inv: fileName is different from expected "
assertSMPAcceptNotProhibited :: ChatItem c d -> CM ()
assertSMPAcceptNotProhibited ChatItem { file = Just CIFile { fileId , fileProtocol } , content }
| fileProtocol == FPXFTP && not ( imageOrVoice content ) = throwChatError $ CEFallbackToSMPProhibited fileId
| otherwise = pure ()
where
imageOrVoice :: CIContent d -> Bool
imageOrVoice ( CISndMsgContent ( MCImage _ _ ) ) = True
imageOrVoice ( CISndMsgContent ( MCVoice _ _ ) ) = True
imageOrVoice _ = False
assertSMPAcceptNotProhibited _ = pure ()
checkSndInlineFTComplete :: Connection -> AgentMsgId -> CM ()
checkSndInlineFTComplete conn agentMsgId = do
sft_ <- withStore' $ \ db -> getSndFTViaMsgDelivery db user conn agentMsgId
forM_ sft_ $ \ sft @ SndFileTransfer { fileId } -> do
ci @ ( AChatItem _ _ _ ChatItem { file } ) <- withStore $ \ db -> do
liftIO $ updateSndFileStatus db sft FSComplete
liftIO $ deleteSndFileChunks db sft
updateDirectCIFileStatus db vr user fileId CIFSSndComplete
case file of
Just CIFile { fileProtocol = FPXFTP } -> do
ft <- withStore $ \ db -> getFileTransferMeta db user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtSndFileCompleteXFTP user ci ft
_ -> toView $ CEvtSndFileComplete user ci sft
2024-12-20 16:54:24 +04:00
allowSendInline :: Integer -> Maybe InlineFileMode -> CM Bool
allowSendInline fileSize = \ case
Just IFMOffer -> do
ChatConfig { fileChunkSize , inlineFiles } <- asks config
pure $ fileSize <= fileChunkSize * offerChunks inlineFiles
_ -> pure False
bFileChunk :: Contact -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunk ct sharedMsgId chunk meta = do
ft <- withStore $ \ db -> getDirectFileIdBySharedMsgId db user ct sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
bFileChunkGroup :: GroupInfo -> SharedMsgId -> FileChunk -> MsgMeta -> CM ()
bFileChunkGroup GroupInfo { groupId } sharedMsgId chunk meta = do
ft <- withStore $ \ db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId >>= getRcvFileTransfer db user
receiveInlineChunk ft chunk meta
receiveInlineChunk :: RcvFileTransfer -> FileChunk -> MsgMeta -> CM ()
receiveInlineChunk RcvFileTransfer { fileId , fileStatus = RFSNew } FileChunk { chunkNo } _
| chunkNo == 1 = throwChatError $ CEInlineFileProhibited fileId
| otherwise = pure ()
receiveInlineChunk ft @ RcvFileTransfer { fileId } chunk meta = do
case chunk of
FileChunk { chunkNo } -> when ( chunkNo == 1 ) $ startReceivingFile user fileId
_ -> pure ()
receiveFileChunk ft Nothing meta chunk
xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> CM ()
2025-02-03 08:55:46 +00:00
xFileCancelGroup g @ GroupInfo { groupId } GroupMember { groupMemberId , memberId } sharedMsgId = do
2024-12-20 16:54:24 +04:00
fileId <- withStore $ \ db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
2025-02-03 08:55:46 +00:00
CChatItem msgDir ChatItem { chatDir } <- withStore $ \ db -> getGroupChatItemBySharedMsgId db user g groupMemberId sharedMsgId
2024-12-20 16:54:24 +04:00
case ( msgDir , chatDir ) of
( SMDRcv , CIGroupRcv m ) -> do
if sameMemberId memberId m
then do
ft <- withStore ( \ db -> getRcvFileTransfer db user fileId )
unless ( rcvFileCompleteOrCancelled ft ) $ do
2025-05-05 11:51:22 +01:00
cancelRcvFileTransfer user ft >>= mapM_ deleteAgentConnectionAsync
2024-12-20 16:54:24 +04:00
ci <- withStore $ \ db -> getChatItemByFileId db vr user fileId
2025-05-04 22:14:36 +01:00
toView $ CEvtRcvFileSndCancelled user ci ft
2024-12-20 16:54:24 +04:00
else messageError " x.file.cancel: group member attempted to cancel file of another member " -- shouldn't happen now that query includes group member id
( SMDSnd , _ ) -> messageError " x.file.cancel: group member attempted invalid file cancel "
xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> CM ()
xFileAcptInvGroup GroupInfo { groupId } m @ GroupMember { activeConn } sharedMsgId fileConnReq_ fName = do
fileId <- withStore $ \ db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId
( AChatItem _ _ _ ci ) <- withStore $ \ db -> getChatItemByFileId db vr user fileId
assertSMPAcceptNotProhibited ci
-- TODO check that it's not already accepted
ft @ FileTransferMeta { fileName , fileSize , fileInline , cancelled } <- withStore ( \ db -> getFileTransferMeta db user fileId )
if fName == fileName
then unless cancelled $ case ( fileConnReq_ , activeConn ) of
( Just fileConnReq , _ ) -> do
subMode <- chatReadVar subscriptionMode
-- receiving via a separate connection
-- [async agent commands] no continuation needed, but command should be asynchronous for stability
dm <- encodeConnInfo XOk
connIds <- joinAgentConnectionAsync user True fileConnReq dm subMode
withStore' $ \ db -> createSndGroupFileTransferConnection db vr user fileId connIds m subMode
( _ , Just conn ) -> do
-- receiving inline
event <- withStore $ \ db -> do
ci' <- updateDirectCIFileStatus db vr user fileId $ CIFSSndTransfer 0 1
sft <- liftIO $ createSndGroupInlineFT db m conn ft
2025-05-04 22:14:36 +01:00
pure $ CEvtSndFileStart user ci' sft
2024-12-20 16:54:24 +04:00
toView event
ifM
( allowSendInline fileSize fileInline )
( sendMemberFileInline m conn ft sharedMsgId )
( messageError " x.file.acpt.inv: fileSize is bigger than allowed to send inline " )
_ -> messageError " x.file.acpt.inv: member connection is not active "
else messageError " x.file.acpt.inv: fileName is different from expected "
2025-05-09 15:36:06 +00:00
groupMsgToView :: forall d . MsgDirectionI d => ChatInfo 'CTGroup -> ChatItem 'CTGroup d -> CM ()
groupMsgToView cInfo ci = do
toView $ CEvtNewChatItems user [ AChatItem SCTGroup ( msgDirection @ d ) cInfo ci ]
2024-12-20 16:54:24 +04:00
processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM ()
processGroupInvitation ct inv msg msgMeta = do
let Contact { localDisplayName = c , activeConn } = ct
GroupInvitation { fromMember = ( MemberIdRole fromMemId fromRole ) , invitedMember = ( MemberIdRole memId memRole ) , connRequest , groupLinkId } = inv
forM_ activeConn $ \ Connection { connId , connChatVersion , peerChatVRange , customUserProfileId , groupLinkId = groupLinkId' } -> do
when ( fromRole < GRAdmin || fromRole < memRole ) $ throwChatError ( CEGroupContactRole c )
when ( fromMemId == memId ) $ throwChatError CEGroupDuplicateMemberId
-- [incognito] if direct connection with host is incognito, create membership using the same incognito profile
( gInfo @ GroupInfo { groupId , localDisplayName , groupProfile , membership } , hostId ) <- withStore $ \ db -> createGroupInvitation db vr user ct inv customUserProfileId
let GroupMember { groupMemberId , memberId = membershipMemId } = membership
if sameGroupLinkId groupLinkId groupLinkId'
then do
subMode <- chatReadVar subscriptionMode
dm <- encodeConnInfo $ XGrpAcpt membershipMemId
connIds <- joinAgentConnectionAsync user True connRequest dm subMode
withStore' $ \ db -> do
setViaGroupLinkHash db groupId connId
createMemberConnectionAsync db user hostId connIds connChatVersion peerChatVRange subMode
updateGroupMemberStatusById db userId hostId GSMemAccepted
updateGroupMemberStatus db userId membership GSMemAccepted
2025-05-04 22:14:36 +01:00
toView $ CEvtUserAcceptedGroupSent user gInfo { membership = membership { memberStatus = GSMemAccepted } } ( Just ct )
2024-12-20 16:54:24 +04:00
else do
let content = CIRcvGroupInvitation ( CIGroupInvitation { groupId , groupMemberId , localDisplayName , groupProfile , status = CIGISPending } ) memRole
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDDirectRcv ct ) msg brokerTs content
2024-12-20 16:54:24 +04:00
withStore' $ \ db -> setGroupInvitationChatItemId db user groupId ( chatItemId' ci )
2025-05-09 15:36:06 +00:00
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2025-05-04 22:14:36 +01:00
toView $ CEvtReceivedGroupInvitation { user , groupInfo = gInfo , contact = ct , fromMemberRole = fromRole , memberRole = memRole }
2024-12-20 16:54:24 +04:00
where
brokerTs = metaBrokerTs msgMeta
sameGroupLinkId :: Maybe GroupLinkId -> Maybe GroupLinkId -> Bool
sameGroupLinkId ( Just gli ) ( Just gli' ) = gli == gli'
sameGroupLinkId _ _ = False
checkIntegrityCreateItem :: forall c . ChatTypeI c => ChatDirection c 'MDRcv -> MsgMeta -> CM ()
checkIntegrityCreateItem cd MsgMeta { integrity , broker = ( _ , brokerTs ) } = case integrity of
MsgOk -> pure ()
MsgError e -> createInternalChatItem user cd ( CIRcvIntegrityError e ) ( Just brokerTs )
xInfo :: Contact -> Profile -> CM ()
xInfo c p' = void $ processContactProfileUpdate c p' True
xDirectDel :: Contact -> RcvMessage -> MsgMeta -> CM ()
xDirectDel c msg msgMeta =
if directOrUsed c
then do
ct' <- withStore' $ \ db -> updateContactStatus db user c CSDeleted
contactConns <- withStore' $ \ db -> getContactConnections db vr userId ct'
2025-05-05 11:51:22 +01:00
deleteAgentConnectionsAsync $ map aConnId contactConns
2024-12-20 16:54:24 +04:00
forM_ contactConns $ \ conn -> withStore' $ \ db -> updateConnectionStatus db conn ConnDeleted
activeConn' <- forM ( contactConn ct' ) $ \ conn -> pure conn { connStatus = ConnDeleted }
let ct'' = ct' { activeConn = activeConn' } :: Contact
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDDirectRcv ct'' ) msg brokerTs ( CIRcvDirectEvent RDEContactDeleted )
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2025-05-04 22:14:36 +01:00
toView $ CEvtContactDeletedByContact user ct''
2024-12-20 16:54:24 +04:00
else do
contactConns <- withStore' $ \ db -> getContactConnections db vr userId c
2025-05-05 11:51:22 +01:00
deleteAgentConnectionsAsync $ map aConnId contactConns
2024-12-20 16:54:24 +04:00
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'
2025-05-04 22:14:36 +01:00
toView $ CEvtContactUpdated user c c'
2024-12-20 16:54:24 +04:00
pure c'
| otherwise =
pure c
where
p = fromLocalProfile lp
Contact { userPreferences = ctUserPrefs @ Preferences { timedMessages = ctUserTMPref } } = c
userTTL = prefParam $ getPreference SCFTimedMessages ctUserPrefs
Profile { preferences = rcvPrefs_ } = p'
rcvTTL = prefParam $ getPreference SCFTimedMessages rcvPrefs_
ctUserPrefs' =
let userDefault = getPreference SCFTimedMessages ( fullPreferences user )
userDefaultTTL = prefParam userDefault
ctUserTMPref' = case ctUserTMPref of
Just userTM -> Just ( userTM :: TimedMessagesPreference ) { ttl = rcvTTL }
_
| rcvTTL /= userDefaultTTL -> Just ( userDefault :: TimedMessagesPreference ) { ttl = rcvTTL }
| otherwise -> Nothing
in setPreference_ SCFTimedMessages ctUserTMPref' ctUserPrefs
createProfileUpdatedItem c' =
when visibleProfileUpdated $ do
let ciContent = CIRcvDirectEvent $ RDEProfileUpdated p p'
createInternalChatItem user ( CDDirectRcv c' ) ciContent Nothing
where
visibleProfileUpdated =
n' /= n || fn' /= fn || i' /= i || cl' /= cl
Profile { displayName = n , fullName = fn , image = i , contactLink = cl } = p
Profile { displayName = n' , fullName = fn' , image = i' , contactLink = cl' } = p'
xInfoMember :: GroupInfo -> GroupMember -> Profile -> UTCTime -> CM ()
xInfoMember gInfo m p' brokerTs = void $ processMemberProfileUpdate gInfo m p' True ( Just brokerTs )
xGrpLinkMem :: GroupInfo -> GroupMember -> Connection -> Profile -> CM ()
2025-04-05 11:25:45 +00:00
xGrpLinkMem gInfo @ GroupInfo { membership , businessChat } m @ GroupMember { groupMemberId , memberCategory } Connection { viaGroupLink } p' = do
2024-12-20 16:54:24 +04:00
xGrpLinkMemReceived <- withStore $ \ db -> getXGrpLinkMemReceived db groupMemberId
if ( viaGroupLink || isJust businessChat ) && isNothing ( memberContactId m ) && memberCategory == GCHostMember && not xGrpLinkMemReceived
then do
m' <- processMemberProfileUpdate gInfo m p' False Nothing
withStore' $ \ db -> setXGrpLinkMemReceived db groupMemberId True
2025-04-03 09:36:28 +00:00
let connectedIncognito = memberIncognito membership
probeMatchingMemberContact m' connectedIncognito
2024-12-20 16:54:24 +04:00
else messageError " x.grp.link.mem error: invalid group link host profile update "
2025-04-28 06:28:40 +00:00
xGrpLinkAcpt :: GroupInfo -> GroupMember -> GroupAcceptance -> GroupMemberRole -> MemberId -> RcvMessage -> UTCTime -> CM ()
xGrpLinkAcpt gInfo @ GroupInfo { membership } m acceptance role memberId msg brokerTs
2025-04-03 09:36:28 +00:00
| 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
2025-05-09 15:36:06 +00:00
( referencedMember' , gInfo' ) <- withFastStore' $ \ db -> do
referencedMember' <- updateGroupMemberAccepted db user referencedMember ( newMemberStatus referencedMember ) role
gInfo' <- updateGroupMembersRequireAttention db user gInfo referencedMember referencedMember'
pure ( referencedMember' , gInfo' )
2025-04-03 09:36:28 +00:00
when ( memberCategory referencedMember == GCInviteeMember ) $ introduceToRemainingMembers referencedMember'
2025-05-13 12:35:54 +00:00
-- create item in both scopes
memberConnectedChatItem gInfo' Nothing referencedMember'
2025-04-07 07:55:56 +00:00
let scopeInfo = Just $ GCSIMemberSupport { groupMember_ = Just referencedMember' }
gEvent = RGEMemberAccepted ( groupMemberId' referencedMember' ) ( fromLocalProfile $ memberProfile referencedMember' )
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo' scopeInfo m ) msg brokerTs ( CIRcvGroupEvent gEvent )
groupMsgToView cInfo ci
toView $ CEvtMemberAcceptedByOther user gInfo' m referencedMember'
2025-04-03 09:36:28 +00:00
where
newMemberStatus refMem = case memberConn refMem of
Just c | connReady c -> GSMemConnected
_ -> GSMemAnnounced
2025-04-02 07:57:18 +00:00
where
2025-04-28 06:28:40 +00:00
processUserAccepted = case acceptance of
GAAccepted -> do
membership' <- withStore' $ \ db -> updateGroupMemberAccepted db user membership GSMemConnected role
2025-05-15 16:05:18 +00:00
-- create item in both scopes
2025-05-14 15:14:34 +00:00
let gInfo' = gInfo { membership = membership' }
2025-05-19 09:08:28 +00:00
cd = CDGroupRcv gInfo' Nothing m
2025-06-20 11:54:21 +01:00
createInternalChatItem user cd ( CIRcvGroupE2EEInfo E2EInfo { pqEnabled = Just PQEncOff } ) Nothing
2025-05-14 15:14:34 +00:00
createGroupFeatureItems user cd CIRcvGroupFeature gInfo'
maybeCreateGroupDescrLocal gInfo' m
2025-05-19 09:08:28 +00:00
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
2025-04-28 06:28:40 +00:00
GAPendingReview -> do
membership' <- withStore' $ \ db -> updateGroupMemberAccepted db user membership GSMemPendingReview role
2025-05-14 15:14:34 +00:00
let gInfo' = gInfo { membership = membership' }
scopeInfo = Just $ GCSIMemberSupport { groupMember_ = Nothing }
createInternalChatItem user ( CDGroupSnd gInfo' scopeInfo ) ( CISndGroupEvent SGEUserPendingReview ) Nothing
toView $ CEvtMemberAcceptedByOther user gInfo' m membership'
2025-04-28 06:28:40 +00:00
GAPendingApproval ->
messageWarning " x.grp.link.acpt: unexpected group acceptance - pending approval "
2025-04-02 07:57:18 +00:00
introduceToRemainingMembers acceptedMember = do
2025-04-03 09:36:28 +00:00
introduceToRemaining vr user gInfo acceptedMember
when ( groupFeatureAllowed SGFHistory gInfo ) $ sendHistory user gInfo acceptedMember
2025-04-02 07:57:18 +00:00
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
2025-03-03 18:57:29 +00:00
2024-12-20 16:54:24 +04:00
processMemberProfileUpdate :: GroupInfo -> GroupMember -> Profile -> Bool -> Maybe UTCTime -> CM GroupMember
processMemberProfileUpdate gInfo m @ GroupMember { memberProfile = p , memberContactId } p' createItems itemTs_
| redactedMemberProfile ( fromLocalProfile p ) /= redactedMemberProfile p' = do
updateBusinessChatProfile gInfo
case memberContactId of
Nothing -> do
m' <- withStore $ \ db -> updateMemberProfile db user m p'
createProfileUpdatedItem m'
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupMemberUpdated user gInfo m m'
2024-12-20 16:54:24 +04:00
pure m'
Just mContactId -> do
mCt <- withStore $ \ db -> getContact db vr user mContactId
if canUpdateProfile mCt
then do
( m' , ct' ) <- withStore $ \ db -> updateContactMemberProfile db user m mCt p'
createProfileUpdatedItem m'
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupMemberUpdated user gInfo m m'
toView $ CEvtContactUpdated user mCt ct'
2024-12-20 16:54:24 +04:00
pure m'
else pure m
where
canUpdateProfile ct
| not ( contactActive ct ) = True
| otherwise = case contactConn ct of
Nothing -> True
Just conn -> not ( connReady conn ) || ( authErrCounter conn >= 1 )
| otherwise =
pure m
where
updateBusinessChatProfile g @ GroupInfo { businessChat } = case businessChat of
Just bc | isMainBusinessMember bc m -> do
g' <- withStore $ \ db -> updateGroupProfileFromMember db user g p'
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupUpdated user g g' ( Just m )
2024-12-20 16:54:24 +04:00
_ -> pure ()
isMainBusinessMember BusinessChatInfo { chatType , businessId , customerId } GroupMember { memberId } = case chatType of
BCBusiness -> businessId == memberId
BCCustomer -> customerId == memberId
createProfileUpdatedItem m' =
when createItems $ do
2025-04-21 15:17:21 +00:00
( gInfo' , m'' , scopeInfo ) <- mkGroupChatScope gInfo m'
2024-12-20 16:54:24 +04:00
let ciContent = CIRcvGroupEvent $ RGEMemberProfileUpdated ( fromLocalProfile p ) p'
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv gInfo' scopeInfo m'' ) ciContent itemTs_
2024-12-20 16:54:24 +04:00
xInfoProbe :: ContactOrMember -> Probe -> CM ()
xInfoProbe cgm2 probe = do
contactMerge <- readTVarIO =<< asks contactMergeEnabled
-- [incognito] unless connected incognito
when ( contactMerge && not ( contactOrMemberIncognito cgm2 ) ) $ do
cgm1s <- withStore' $ \ db -> matchReceivedProbe db vr user cgm2 probe
let cgm1s' = filter ( not . contactOrMemberIncognito ) cgm1s
probeMatches cgm1s' cgm2
where
probeMatches :: [ ContactOrMember ] -> ContactOrMember -> CM ()
probeMatches [] _ = pure ()
probeMatches ( cgm1' : cgm1s' ) cgm2' = do
cgm2''_ <- probeMatch cgm1' cgm2' probe ` catchChatError ` \ _ -> pure ( Just cgm2' )
let cgm2'' = fromMaybe cgm2' cgm2''_
probeMatches cgm1s' cgm2''
xInfoProbeCheck :: ContactOrMember -> ProbeHash -> CM ()
xInfoProbeCheck cgm1 probeHash = do
contactMerge <- readTVarIO =<< asks contactMergeEnabled
-- [incognito] unless connected incognito
when ( contactMerge && not ( contactOrMemberIncognito cgm1 ) ) $ do
cgm2Probe_ <- withStore' $ \ db -> matchReceivedProbeHash db vr user cgm1 probeHash
forM_ cgm2Probe_ $ \ ( cgm2 , probe ) ->
unless ( contactOrMemberIncognito cgm2 ) . void $
probeMatch cgm1 cgm2 probe
probeMatch :: ContactOrMember -> ContactOrMember -> Probe -> CM ( Maybe ContactOrMember )
probeMatch cgm1 cgm2 probe =
case cgm1 of
COMContact c1 @ Contact { contactId = cId1 , profile = p1 } ->
case cgm2 of
COMContact c2 @ Contact { contactId = cId2 , profile = p2 }
| cId1 /= cId2 && profilesMatch p1 p2 -> do
void . sendDirectContactMessage user c1 $ XInfoProbeOk probe
COMContact <$$> mergeContacts c1 c2
| otherwise -> messageWarning " probeMatch ignored: profiles don't match or same contact id " >> pure Nothing
COMGroupMember m2 @ GroupMember { memberProfile = p2 , memberContactId }
| isNothing memberContactId && profilesMatch p1 p2 -> do
void . sendDirectContactMessage user c1 $ XInfoProbeOk probe
COMContact <$$> associateMemberAndContact c1 m2
| otherwise -> messageWarning " probeMatch ignored: profiles don't match or member already has contact " >> pure Nothing
COMGroupMember GroupMember { activeConn = Nothing } -> pure Nothing
COMGroupMember m1 @ GroupMember { groupId , memberProfile = p1 , memberContactId , activeConn = Just conn } ->
case cgm2 of
COMContact c2 @ Contact { profile = p2 }
| memberCurrent m1 && isNothing memberContactId && profilesMatch p1 p2 -> do
void $ sendDirectMemberMessage conn ( XInfoProbeOk probe ) groupId
COMContact <$$> associateMemberAndContact c2 m1
| otherwise -> messageWarning " probeMatch ignored: profiles don't match or member already has contact or member not current " >> pure Nothing
COMGroupMember _ -> messageWarning " probeMatch ignored: members are not matched with members " >> pure Nothing
xInfoProbeOk :: ContactOrMember -> Probe -> CM ()
xInfoProbeOk cgm1 probe = do
cgm2 <- withStore' $ \ db -> matchSentProbe db vr user cgm1 probe
case cgm1 of
COMContact c1 @ Contact { contactId = cId1 } ->
case cgm2 of
Just ( COMContact c2 @ Contact { contactId = cId2 } )
| cId1 /= cId2 -> void $ mergeContacts c1 c2
| otherwise -> messageWarning " xInfoProbeOk ignored: same contact id "
Just ( COMGroupMember m2 @ GroupMember { memberContactId } )
| isNothing memberContactId -> void $ associateMemberAndContact c1 m2
| otherwise -> messageWarning " xInfoProbeOk ignored: member already has contact "
_ -> pure ()
COMGroupMember m1 @ GroupMember { memberContactId } ->
case cgm2 of
Just ( COMContact c2 )
| isNothing memberContactId -> void $ associateMemberAndContact c2 m1
| otherwise -> messageWarning " xInfoProbeOk ignored: member already has contact "
Just ( COMGroupMember _ ) -> messageWarning " xInfoProbeOk ignored: members are not matched with members "
_ -> pure ()
-- to party accepting call
xCallInv :: Contact -> CallId -> CallInvitation -> RcvMessage -> MsgMeta -> CM ()
xCallInv ct @ Contact { contactId } callId CallInvitation { callType , callDhPubKey } msg @ RcvMessage { sharedMsgId_ } msgMeta = do
if featureAllowed SCFCalls forContact ct
then do
g <- asks random
dhKeyPair <- atomically $ if encryptedCall callType then Just <$> C . generateKeyPair g else pure Nothing
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveCallItem CISCallPending
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtCallInvitation RcvCallInvitation { user , contact = ct , callType , sharedKey , callUUID , callTs = chatItemTs' ci }
2025-05-09 15:36:06 +00:00
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2024-12-20 16:54:24 +04:00
else featureRejected CFCalls
where
brokerTs = metaBrokerTs msgMeta
2025-01-29 13:04:48 +00:00
saveCallItem status = saveRcvChatItemNoParse user ( CDDirectRcv ct ) msg brokerTs ( CIRcvCall status 0 )
2024-12-20 16:54:24 +04:00
featureRejected f = do
2025-01-29 13:04:48 +00:00
let content = ciContentNoParse $ CIRcvChatFeatureRejected f
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem' user ( CDDirectRcv ct ) msg sharedMsgId_ brokerTs content Nothing Nothing False M . empty
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2024-12-20 16:54:24 +04:00
-- 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 )
2025-05-04 22:14:36 +01:00
toView CEvtCallOffer { user , contact = ct , callType , offer = rtcSession , sharedKey , askConfirmation }
2024-12-20 16:54:24 +04:00
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 }
2025-05-04 22:14:36 +01:00
toView $ CEvtCallAnswer user ct rtcSession
2024-12-20 16:54:24 +04:00
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 }
2025-05-04 22:14:36 +01:00
toView $ CEvtCallExtraInfo user ct rtcExtraInfo
2024-12-20 16:54:24 +04:00
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 }
2025-05-04 22:14:36 +01:00
toView $ CEvtCallExtraInfo user ct rtcExtraInfo
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
toView $ CEvtCallEnded user ct
2024-12-20 16:54:24 +04:00
( 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' ) $
2025-04-02 07:57:18 +00:00
startProximateTimedItemThread user ( ChatRef CTDirect ctId' Nothing , chatItemId )
2024-12-20 16:54:24 +04:00
msgCallStateError :: Text -> Call -> CM ()
msgCallStateError eventName Call { callState } =
messageError $ eventName <> " : wrong call state " <> T . pack ( show $ callStateTag callState )
mergeContacts :: Contact -> Contact -> CM ( Maybe Contact )
mergeContacts c1 c2 = do
let Contact { localDisplayName = cLDN1 , profile = LocalProfile { displayName } } = c1
Contact { localDisplayName = cLDN2 } = c2
case ( suffixOrd displayName cLDN1 , suffixOrd displayName cLDN2 ) of
( Just cOrd1 , Just cOrd2 )
| cOrd1 < cOrd2 -> merge c1 c2
| cOrd2 < cOrd1 -> merge c2 c1
| otherwise -> pure Nothing
_ -> pure Nothing
where
merge c1' c2' = do
c2'' <- withStore $ \ db -> mergeContactRecords db vr user c1' c2'
2025-05-04 22:14:36 +01:00
toView $ CEvtContactsMerged user c1' c2' c2''
2024-12-20 16:54:24 +04:00
when ( directOrUsed c2'' ) $ showSecurityCodeChanged c2''
pure $ Just c2''
where
showSecurityCodeChanged mergedCt = do
let sc1_ = contactSecurityCode c1'
sc2_ = contactSecurityCode c2'
scMerged_ = contactSecurityCode mergedCt
case ( sc1_ , sc2_ ) of
( Just sc1 , Nothing )
| scMerged_ /= Just sc1 -> securityCodeChanged mergedCt
| otherwise -> pure ()
( Nothing , Just sc2 )
| scMerged_ /= Just sc2 -> securityCodeChanged mergedCt
| otherwise -> pure ()
_ -> pure ()
associateMemberAndContact :: Contact -> GroupMember -> CM ( Maybe Contact )
associateMemberAndContact c m = do
let Contact { localDisplayName = cLDN , profile = LocalProfile { displayName } } = c
GroupMember { localDisplayName = mLDN } = m
case ( suffixOrd displayName cLDN , suffixOrd displayName mLDN ) of
( Just cOrd , Just mOrd )
| cOrd < mOrd -> Just <$> associateMemberWithContact c m
| mOrd < cOrd -> Just <$> associateContactWithMember m c
| otherwise -> pure Nothing
_ -> pure Nothing
suffixOrd :: ContactName -> ContactName -> Maybe Int
suffixOrd displayName localDisplayName
| localDisplayName == displayName = Just 0
| otherwise = case T . stripPrefix ( displayName <> " _ " ) localDisplayName of
Just suffix -> readMaybe $ T . unpack suffix
Nothing -> Nothing
associateMemberWithContact :: Contact -> GroupMember -> CM Contact
associateMemberWithContact c1 m2 @ GroupMember { groupId } = do
withStore' $ \ db -> associateMemberWithContactRecord db user c1 m2
g <- withStore $ \ db -> getGroupInfo db vr user groupId
2025-05-04 22:14:36 +01:00
toView $ CEvtContactAndMemberAssociated user c1 g m2 c1
2024-12-20 16:54:24 +04:00
pure c1
associateContactWithMember :: GroupMember -> Contact -> CM Contact
associateContactWithMember m1 @ GroupMember { groupId } c2 = do
c2' <- withStore $ \ db -> associateContactWithMemberRecord db vr user m1 c2
g <- withStore $ \ db -> getGroupInfo db vr user groupId
2025-05-04 22:14:36 +01:00
toView $ CEvtContactAndMemberAssociated user c2 g m1 c2'
2024-12-20 16:54:24 +04:00
pure c2'
saveConnInfo :: Connection -> ConnInfo -> CM ( Connection , Bool )
saveConnInfo activeConn connInfo = do
ChatMessage { chatVRange , chatMsgEvent } <- parseChatMessage activeConn connInfo
conn' <- updatePeerChatVRange activeConn chatVRange
case chatMsgEvent of
XInfo p -> do
2025-01-31 10:32:07 +04:00
ct <- withStore $ \ db -> createDirectContact db user conn' p
2025-05-04 22:14:36 +01:00
toView $ CEvtContactConnecting user ct
2024-12-20 16:54:24 +04:00
pure ( conn' , False )
XGrpLinkInv glInv -> do
( gInfo , host ) <- withStore $ \ db -> createGroupInvitedViaLink db vr user conn' glInv
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupLinkConnecting user gInfo host
2024-12-20 16:54:24 +04:00
pure ( conn' , True )
2025-02-25 14:05:49 +04:00
XGrpLinkReject glRjct @ GroupLinkRejection { rejectionReason } -> do
( gInfo , host ) <- withStore $ \ db -> createGroupRejectedViaLink db vr user conn' glRjct
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupLinkConnecting user gInfo host
2025-02-25 14:05:49 +04:00
toViewTE $ TEGroupLinkRejected user gInfo rejectionReason
pure ( conn' , True )
2024-12-20 16:54:24 +04:00
-- TODO show/log error, other events in SMP confirmation
_ -> pure ( conn' , False )
2025-04-02 07:57:18 +00:00
xGrpMemNew :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MsgScope -> RcvMessage -> UTCTime -> CM ()
xGrpMemNew gInfo m memInfo @ ( MemberInfo memId memRole _ _ ) msgScope_ msg brokerTs = do
2024-12-20 16:54:24 +04:00
checkHostRole m memRole
unless ( sameMemberId memId $ membership gInfo ) $
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
Right unknownMember @ GroupMember { memberStatus = GSMemUnknown } -> do
2025-05-09 15:36:06 +00:00
( 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' )
toView $ CEvtUnknownMemberAnnounced user gInfo' m unknownMember updatedMember
memberAnnouncedToView updatedMember gInfo'
2024-12-20 16:54:24 +04:00
Right _ -> messageError " x.grp.mem.new error: member already exists "
Left _ -> do
2025-05-09 15:36:06 +00:00
( 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' )
memberAnnouncedToView newMember gInfo'
2024-12-20 16:54:24 +04:00
where
2025-04-02 07:57:18 +00:00
initialStatus = case msgScope_ of
Just ( MSMember _ ) -> GSMemPendingReview
_ -> GSMemAnnounced
2025-05-09 15:36:06 +00:00
memberAnnouncedToView announcedMember @ GroupMember { groupMemberId , memberProfile } gInfo' = do
2025-04-21 15:17:21 +00:00
( announcedMember' , scopeInfo ) <- getMemNewChatScope announcedMember
2024-12-20 16:54:24 +04:00
let event = RGEMemberAdded groupMemberId ( fromLocalProfile memberProfile )
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo' scopeInfo m ) msg brokerTs ( CIRcvGroupEvent event )
groupMsgToView cInfo ci
2025-04-28 10:45:42 +00:00
case scopeInfo of
Just ( GCSIMemberSupport _ ) -> do
2025-05-09 15:36:06 +00:00
createInternalChatItem user ( CDGroupRcv gInfo' scopeInfo m ) ( CIRcvGroupEvent RGENewMemberPendingReview ) ( Just brokerTs )
2025-04-28 10:45:42 +00:00
_ -> pure ()
2025-05-09 15:36:06 +00:00
toView $ CEvtJoinedGroupMemberConnecting user gInfo' m announcedMember'
2025-04-02 07:57:18 +00:00
getMemNewChatScope announcedMember = case msgScope_ of
Nothing -> pure ( announcedMember , Nothing )
Just ( MSMember _ ) -> do
( announcedMember' , scopeInfo ) <- mkMemberSupportChatInfo announcedMember
pure ( announcedMember' , Just scopeInfo )
2024-12-20 16:54:24 +04:00
xGrpMemIntro :: GroupInfo -> GroupMember -> MemberInfo -> Maybe MemberRestrictions -> CM ()
2025-04-28 06:28:40 +00:00
xGrpMemIntro gInfo @ GroupInfo { chatSettings } m @ GroupMember { memberRole , localDisplayName = c } memInfo @ ( MemberInfo memId _ memChatVRange _ ) memRestrictions = do
2024-12-20 16:54:24 +04:00
case memberCategory m of
GCHostMember ->
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
Right _ -> messageError " x.grp.mem.intro ignored: member already exists "
Left _ -> do
when ( memberRole < GRAdmin ) $ throwChatError ( CEGroupContactRole c )
2025-01-31 10:32:07 +04:00
case memChatVRange of
Nothing -> messageError " x.grp.mem.intro: member chat version range incompatible "
2024-12-20 16:54:24 +04:00
Just ( ChatVersionRange mcvr )
2025-01-31 10:32:07 +04:00
| 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 -> createIntroReMember db user gInfo m chatV memInfo memRestrictions groupConnIds subMode
| otherwise -> messageError " x.grp.mem.intro: member chat version range incompatible "
2024-12-20 16:54:24 +04:00
_ -> messageError " x.grp.mem.intro can be only sent by host member "
where
createConn subMode = createAgentConnectionAsync user CFCreateConnGrpMemInv ( chatHasNtfs chatSettings ) SCMInvitation subMode
sendXGrpMemInv :: Int64 -> Maybe ConnReqInvitation -> XGrpMemIntroCont -> CM ()
sendXGrpMemInv hostConnId directConnReq XGrpMemIntroCont { groupId , groupMemberId , memberId , groupConnReq } = do
hostConn <- withStore $ \ db -> getConnectionById db vr user hostConnId
let msg = XGrpMemInv memberId IntroInvitation { groupConnReq , directConnReq }
void $ sendDirectMemberMessage hostConn msg groupId
withStore' $ \ db -> updateGroupMemberStatusById db userId groupMemberId GSMemIntroInvited
xGrpMemInv :: GroupInfo -> GroupMember -> MemberId -> IntroInvitation -> CM ()
xGrpMemInv gInfo m memId introInv = do
case memberCategory m of
GCInviteeMember ->
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
Left _ -> messageError " x.grp.mem.inv error: referenced member does not exist "
Right reMember -> do
GroupMemberIntro { introId } <- withStore $ \ db -> saveIntroInvitation db reMember m introInv
2025-05-05 11:51:22 +01:00
sendGroupMemberMessage gInfo reMember ( XGrpMemFwd ( memberInfo m ) introInv ) ( Just introId ) $
2024-12-20 16:54:24 +04:00
withStore' $
\ db -> updateIntroStatus db introId GMIntroInvForwarded
_ -> messageError " x.grp.mem.inv can be only sent by invitee member "
xGrpMemFwd :: GroupInfo -> GroupMember -> MemberInfo -> IntroInvitation -> CM ()
xGrpMemFwd gInfo @ GroupInfo { membership , chatSettings } m memInfo @ ( MemberInfo memId memRole memChatVRange _ ) introInv @ IntroInvitation { groupConnReq , directConnReq } = do
let GroupMember { memberId = membershipMemId } = membership
checkHostRole m memRole
toMember <-
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
-- TODO if the missed messages are correctly sent as soon as there is connection before anything else is sent
-- the situation when member does not exist is an error
-- member receiving x.grp.mem.fwd should have also received x.grp.mem.new prior to that.
-- For now, this branch compensates for the lack of delayed message delivery.
Left _ -> withStore $ \ db -> createNewGroupMember db user gInfo m memInfo GCPostMember GSMemAnnounced
Right m' -> pure m'
2025-04-02 07:57:18 +00:00
-- 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
withStore' $ \ db -> saveMemberInvitation db toMember introInv newMemberStatus
2024-12-20 16:54:24 +04:00
subMode <- chatReadVar subscriptionMode
-- [incognito] send membership incognito profile, create direct connection as incognito
let membershipProfile = redactedMemberProfile $ fromLocalProfile $ memberProfile membership
dm <- encodeConnInfo $ XGrpMemInfo membershipMemId membershipProfile
-- [async agent commands] no continuation needed, but commands should be asynchronous for stability
groupConnIds <- joinAgentConnectionAsync user ( chatHasNtfs chatSettings ) groupConnReq dm subMode
directConnIds <- forM directConnReq $ \ dcr -> joinAgentConnectionAsync user True dcr dm subMode
let customUserProfileId = localProfileId <$> incognitoMembershipProfile gInfo
mcvr = maybe chatInitialVRange fromChatVRange memChatVRange
chatV = vr ` peerConnChatVersion ` mcvr
withStore' $ \ db -> createIntroToMemberContact db user m toMember chatV mcvr groupConnIds directConnIds customUserProfileId subMode
xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> CM ()
xGrpMemRole gInfo @ GroupInfo { membership } m @ GroupMember { memberRole = senderRole } memId memRole msg brokerTs
| membershipMemId == memId =
let gInfo' = gInfo { membership = membership { memberRole = memRole } }
in changeMemberRole gInfo' membership $ RGEUserRole memRole
| otherwise =
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
Right member -> changeMemberRole gInfo member $ RGEMemberRole ( groupMemberId' member ) ( fromLocalProfile $ memberProfile member ) memRole
Left _ -> messageError " x.grp.mem.role with unknown member ID "
where
GroupMember { memberId = membershipMemId } = membership
changeMemberRole gInfo' member @ GroupMember { memberRole = fromRole } gEvent
| senderRole < GRAdmin || senderRole < fromRole = messageError " x.grp.mem.role with insufficient member permissions "
| otherwise = do
withStore' $ \ db -> updateGroupMemberRole db user member memRole
2025-04-21 15:17:21 +00:00
( gInfo'' , m' , scopeInfo ) <- mkGroupChatScope gInfo' m
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo'' scopeInfo m' ) msg brokerTs ( CIRcvGroupEvent gEvent )
groupMsgToView cInfo ci
2025-05-04 23:25:50 +01:00
toView CEvtMemberRole { user , groupInfo = gInfo'' , byMember = m' , member = member { memberRole = memRole } , fromRole , toRole = memRole }
2024-12-20 16:54:24 +04:00
checkHostRole :: GroupMember -> GroupMemberRole -> CM ()
checkHostRole GroupMember { memberRole , localDisplayName } memRole =
when ( memberRole < GRAdmin || memberRole < memRole ) $ throwChatError ( CEGroupContactRole localDisplayName )
xGrpMemRestrict :: GroupInfo -> GroupMember -> MemberId -> MemberRestrictions -> RcvMessage -> UTCTime -> CM ()
xGrpMemRestrict
2025-02-28 22:43:39 +04:00
gInfo @ GroupInfo { membership = GroupMember { memberId = membershipMemId } }
2024-12-20 16:54:24 +04:00
m @ GroupMember { memberRole = senderRole }
memId
MemberRestrictions { restriction }
msg
brokerTs
| membershipMemId == memId =
-- member shouldn't receive this message about themselves
messageError " x.grp.mem.restrict: admin blocks you "
| otherwise =
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
2025-02-28 22:43:39 +04:00
Right bm @ GroupMember { groupMemberId = bmId , memberRole , blockedByAdmin , memberProfile = bmp }
| blockedByAdmin == mrsBlocked restriction -> pure ()
2025-01-04 19:17:19 +00:00
| senderRole < GRModerator || senderRole < memberRole -> messageError " x.grp.mem.restrict with insufficient member permissions "
2024-12-20 16:54:24 +04:00
| otherwise -> do
2025-02-28 22:43:39 +04:00
bm' <- setMemberBlocked bm
2025-05-05 11:51:22 +01:00
toggleNtf bm' ( not blocked )
2024-12-20 16:54:24 +04:00
let ciContent = CIRcvGroupEvent $ RGEMemberBlocked bmId ( fromLocalProfile bmp ) blocked
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo' scopeInfo m' ) msg brokerTs ciContent
groupMsgToView cInfo ci
2025-05-04 23:25:50 +01:00
toView CEvtMemberBlockedForAll { user , groupInfo = gInfo' , byMember = m' , member = bm , blocked }
2024-12-20 16:54:24 +04:00
Left ( SEGroupMemberNotFoundByMemberId _ ) -> do
bm <- createUnknownMember gInfo memId
2025-02-28 22:43:39 +04:00
bm' <- setMemberBlocked bm
2025-05-04 22:14:36 +01:00
toView $ CEvtUnknownMemberBlocked user gInfo m bm'
2024-12-20 16:54:24 +04:00
Left e -> throwError $ ChatErrorStore e
where
2025-02-28 22:43:39 +04:00
setMemberBlocked bm = withStore' $ \ db -> updateGroupMemberBlocked db user gInfo restriction bm
2024-12-20 16:54:24 +04:00
blocked = mrsBlocked restriction
xGrpMemCon :: GroupInfo -> GroupMember -> MemberId -> CM ()
xGrpMemCon gInfo sendingMember memId = do
refMember <- withStore $ \ db -> getGroupMemberByMemberId db vr user gInfo memId
case ( memberCategory sendingMember , memberCategory refMember ) of
( GCInviteeMember , GCInviteeMember ) ->
withStore' ( \ db -> runExceptT $ getIntroduction db refMember sendingMember ) >>= \ case
Right intro -> inviteeXGrpMemCon intro
Left _ ->
withStore' ( \ db -> runExceptT $ getIntroduction db sendingMember refMember ) >>= \ case
Right intro -> forwardMemberXGrpMemCon intro
Left _ -> messageWarning " x.grp.mem.con: no introduction "
( GCInviteeMember , _ ) ->
withStore' ( \ db -> runExceptT $ getIntroduction db refMember sendingMember ) >>= \ case
Right intro -> inviteeXGrpMemCon intro
Left _ -> messageWarning " x.grp.mem.con: no introduction "
( _ , GCInviteeMember ) ->
withStore' ( \ db -> runExceptT $ getIntroduction db sendingMember refMember ) >>= \ case
Right intro -> forwardMemberXGrpMemCon intro
Left _ -> messageWarning " x.grp.mem.con: no introductiosupportn "
-- Note: we can allow XGrpMemCon to all member categories if we decide to support broader group forwarding,
-- deduplication (see saveGroupRcvMsg, saveGroupFwdRcvMsg) already supports sending XGrpMemCon
-- to any forwarding member, not only host/inviting member;
-- database would track all members connections then
-- (currently it's done via group_member_intros for introduced connections only)
_ ->
messageWarning " x.grp.mem.con: neither member is invitee "
where
inviteeXGrpMemCon :: GroupMemberIntro -> CM ()
inviteeXGrpMemCon GroupMemberIntro { introId , introStatus } = case introStatus of
GMIntroReConnected -> updateStatus introId GMIntroConnected
GMIntroToConnected -> pure ()
GMIntroConnected -> pure ()
_ -> updateStatus introId GMIntroToConnected
forwardMemberXGrpMemCon :: GroupMemberIntro -> CM ()
forwardMemberXGrpMemCon GroupMemberIntro { introId , introStatus } = case introStatus of
GMIntroToConnected -> updateStatus introId GMIntroConnected
GMIntroReConnected -> pure ()
GMIntroConnected -> pure ()
_ -> updateStatus introId GMIntroReConnected
updateStatus introId status = withStore' $ \ db -> updateIntroStatus db introId status
2025-03-07 07:47:32 +00:00
xGrpMemDel :: GroupInfo -> GroupMember -> MemberId -> Bool -> RcvMessage -> UTCTime -> CM ()
xGrpMemDel gInfo @ GroupInfo { membership } m @ GroupMember { memberRole = senderRole } memId withMessages msg brokerTs = do
2024-12-20 16:54:24 +04:00
let GroupMember { memberId = membershipMemId } = membership
if membershipMemId == memId
then checkRole membership $ do
deleteGroupLinkIfExists user gInfo
-- member records are not deleted to keep history
members <- withStore' $ \ db -> getGroupMembers db vr user gInfo
deleteMembersConnections user members
withStore' $ \ db -> updateGroupMemberStatus db userId membership GSMemRemoved
2025-03-07 07:47:32 +00:00
when withMessages $ deleteMessages membership SMDSnd
2024-12-20 16:54:24 +04:00
deleteMemberItem RGEUserDeleted
2025-05-04 22:14:36 +01:00
toView $ CEvtDeletedMemberUser user gInfo { membership = membership { memberStatus = GSMemRemoved } } m withMessages
2024-12-20 16:54:24 +04:00
else
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId ) >>= \ case
Left _ -> messageError " x.grp.mem.del with unknown member ID "
Right member @ GroupMember { groupMemberId , memberProfile } ->
checkRole member $ do
-- ? prohibit deleting member if it's the sender - sender should use x.grp.leave
2025-05-05 11:51:22 +01:00
deleteMemberConnection member
2024-12-20 16:54:24 +04:00
-- undeleted "member connected" chat item will prevent deletion of member record
2025-05-16 15:03:15 +00:00
gInfo' <- deleteOrUpdateMemberRecord user gInfo member
2025-03-07 07:47:32 +00:00
when withMessages $ deleteMessages member SMDRcv
2024-12-20 16:54:24 +04:00
deleteMemberItem $ RGEMemberDeleted groupMemberId ( fromLocalProfile memberProfile )
2025-05-16 15:03:15 +00:00
toView $ CEvtDeletedMember user gInfo' m member { memberStatus = GSMemRemoved } withMessages
2024-12-20 16:54:24 +04:00
where
checkRole GroupMember { memberRole } a
| senderRole < GRAdmin || senderRole < memberRole =
messageError " x.grp.mem.del with insufficient member permissions "
| otherwise = a
deleteMemberItem gEvent = do
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo' scopeInfo m' ) msg brokerTs ( CIRcvGroupEvent gEvent )
groupMsgToView cInfo ci
2025-03-07 07:47:32 +00:00
deleteMessages :: MsgDirectionI d => GroupMember -> SMsgDirection d -> CM ()
deleteMessages delMem msgDir
| groupFeatureMemberAllowed SGFFullDelete m gInfo = deleteGroupMemberCIs user gInfo delMem m msgDir
| otherwise = markGroupMemberCIsDeleted user gInfo delMem m
2024-12-20 16:54:24 +04:00
xGrpLeave :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpLeave gInfo m msg brokerTs = do
2025-05-05 11:51:22 +01:00
deleteMemberConnection m
2024-12-20 16:54:24 +04:00
-- member record is not deleted to allow creation of "member left" chat item
2025-05-16 15:03:15 +00:00
gInfo' <- withStore' $ \ db -> do
updateGroupMemberStatus db userId m GSMemLeft
if gmRequiresAttention m
then decreaseGroupMembersRequireAttention db user gInfo
else pure gInfo
( gInfo'' , m' , scopeInfo ) <- mkGroupChatScope gInfo' m
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo'' scopeInfo m' ) msg brokerTs ( CIRcvGroupEvent RGEMemberLeft )
2025-05-09 15:36:06 +00:00
groupMsgToView cInfo ci
2025-05-16 15:03:15 +00:00
toView $ CEvtLeftMember user gInfo'' m' { memberStatus = GSMemLeft }
2024-12-20 16:54:24 +04:00
xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> UTCTime -> CM ()
xGrpDel gInfo @ GroupInfo { membership } m @ GroupMember { memberRole } msg brokerTs = do
when ( memberRole /= GROwner ) $ throwChatError $ CEGroupUserRole gInfo GROwner
ms <- withStore' $ \ db -> do
members <- getGroupMembers db vr user gInfo
updateGroupMemberStatus db userId membership GSMemGroupDeleted
pure members
-- member records are not deleted to keep history
deleteMembersConnections user ms
2025-04-21 15:17:21 +00:00
( gInfo'' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user ( CDGroupRcv gInfo'' scopeInfo m' ) msg brokerTs ( CIRcvGroupEvent RGEGroupDeleted )
groupMsgToView cInfo ci
2025-05-04 23:25:50 +01:00
toView $ CEvtGroupDeleted user gInfo'' { membership = membership { memberStatus = GSMemGroupDeleted } } m'
2024-12-20 16:54:24 +04:00
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> UTCTime -> CM ()
xGrpInfo g @ GroupInfo { groupProfile = p , businessChat } m @ GroupMember { memberRole } p' msg brokerTs
| memberRole < GROwner = messageError " x.grp.info with insufficient member permissions "
| otherwise = case businessChat of
Nothing -> unless ( p == p' ) $ do
g' <- withStore $ \ db -> updateGroupProfile db user g p'
2025-04-21 15:17:21 +00:00
( g'' , m' , scopeInfo ) <- mkGroupChatScope g' m
2025-05-04 23:25:50 +01:00
toView $ CEvtGroupUpdated user g g'' ( Just m' )
2025-04-02 07:57:18 +00:00
let cd = CDGroupRcv g'' scopeInfo m'
2024-12-20 16:54:24 +04:00
unless ( sameGroupProfileInfo p p' ) $ do
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItemNoParse user cd msg brokerTs ( CIRcvGroupEvent $ RGEGroupUpdated p' )
groupMsgToView cInfo ci
2025-04-02 07:57:18 +00:00
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
2024-12-20 16:54:24 +04:00
Just _ -> updateGroupPrefs_ g m $ fromMaybe defaultBusinessGroupPrefs $ groupPreferences p'
xGrpPrefs :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
xGrpPrefs g m @ GroupMember { memberRole } ps'
| memberRole < GROwner = messageError " x.grp.prefs with insufficient member permissions "
| otherwise = updateGroupPrefs_ g m ps'
updateGroupPrefs_ :: GroupInfo -> GroupMember -> GroupPreferences -> CM ()
updateGroupPrefs_ g @ GroupInfo { groupProfile = p } m ps' =
unless ( groupPreferences p == Just ps' ) $ do
g' <- withStore' $ \ db -> updateGroupPreferences db user g ps'
2025-05-04 22:14:36 +01:00
toView $ CEvtGroupUpdated user g g' ( Just m )
2025-04-21 15:17:21 +00:00
( g'' , m' , scopeInfo ) <- mkGroupChatScope g' m
2025-04-02 07:57:18 +00:00
let cd = CDGroupRcv g'' scopeInfo m'
createGroupFeatureChangedItems user cd CIRcvGroupFeature g g''
2024-12-20 16:54:24 +04:00
xGrpDirectInv :: GroupInfo -> GroupMember -> Connection -> ConnReqInvitation -> Maybe MsgContent -> RcvMessage -> UTCTime -> CM ()
xGrpDirectInv g m mConn connReq mContent_ msg brokerTs = do
unless ( groupFeatureMemberAllowed SGFDirectMessages m g ) $ messageError " x.grp.direct.inv: direct messages not allowed "
let GroupMember { memberContactId } = m
subMode <- chatReadVar subscriptionMode
case memberContactId of
Nothing -> createNewContact subMode
Just mContactId -> do
mCt <- withStore $ \ db -> getContact db vr user mContactId
let Contact { activeConn , contactGrpInvSent } = mCt
forM_ activeConn $ \ Connection { connId } ->
if contactGrpInvSent
then do
ownConnReq <- withStore $ \ db -> getConnReqInv db connId
-- in case both members sent x.grp.direct.inv before receiving other's for processing,
-- only the one who received greater connReq joins, the other creates items and waits for confirmation
if strEncode connReq > strEncode ownConnReq
then joinExistingContact subMode mCt
else createItems mCt m
else joinExistingContact subMode mCt
where
joinExistingContact subMode mCt = do
connIds <- joinConn subMode
mCt' <- withStore $ \ db -> updateMemberContactInvited db user connIds g mConn mCt subMode
createItems mCt' m
securityCodeChanged mCt'
createNewContact subMode = do
connIds <- joinConn subMode
-- [incognito] reuse membership incognito profile
( mCt' , m' ) <- withStore' $ \ db -> createMemberContactInvited db user connIds g m mConn subMode
createItems mCt' m'
joinConn subMode = do
-- [incognito] send membership incognito profile
let p = userProfileToSend user ( fromLocalProfile <$> incognitoMembershipProfile g ) Nothing False
-- TODO PQ should negotitate contact connection with PQSupportOn? (use encodeConnInfoPQ)
dm <- encodeConnInfo $ XInfo p
joinAgentConnectionAsync user True connReq dm subMode
createItems mCt' m' = do
2025-04-21 15:17:21 +00:00
( g' , m'' , scopeInfo ) <- mkGroupChatScope g m'
2025-04-02 07:57:18 +00:00
createInternalChatItem user ( CDGroupRcv g' scopeInfo m'' ) ( CIRcvGroupEvent RGEMemberCreatedContact ) Nothing
2025-05-04 23:25:50 +01:00
toView $ CEvtNewMemberContactReceivedInv user mCt' g' m''
2024-12-20 16:54:24 +04:00
forM_ mContent_ $ \ mc -> do
2025-05-09 15:36:06 +00:00
( ci , cInfo ) <- saveRcvChatItem user ( CDDirectRcv mCt' ) msg brokerTs ( CIRcvMsgContent mc , msgContentTexts mc )
toView $ CEvtNewChatItems user [ AChatItem SCTDirect SMDRcv cInfo ci ]
2024-12-20 16:54:24 +04:00
securityCodeChanged :: Contact -> CM ()
securityCodeChanged ct = do
2025-05-04 22:14:36 +01:00
toViewTE $ TEContactVerificationReset user ct
2024-12-20 16:54:24 +04:00
createInternalChatItem user ( CDDirectRcv ct ) ( CIRcvConnEvent RCEVerificationCodeReset ) Nothing
xGrpMsgForward :: GroupInfo -> GroupMember -> MemberId -> ChatMessage 'Json -> UTCTime -> CM ()
xGrpMsgForward gInfo @ GroupInfo { groupId } m @ GroupMember { memberRole , localDisplayName } memberId msg msgTs = do
when ( memberRole < GRAdmin ) $ throwChatError ( CEGroupContactRole localDisplayName )
withStore' ( \ db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memberId ) >>= \ case
Right author -> processForwardedMsg author msg
Left ( SEGroupMemberNotFoundByMemberId _ ) -> do
unknownAuthor <- createUnknownMember gInfo memberId
2025-05-04 22:14:36 +01:00
toView $ CEvtUnknownMemberCreated user gInfo m unknownAuthor
2024-12-20 16:54:24 +04:00
processForwardedMsg unknownAuthor msg
Left e -> throwError $ ChatErrorStore e
where
-- Note: forwarded group events (see forwardedGroupMsg) should include msgId to be deduplicated
processForwardedMsg :: GroupMember -> ChatMessage 'Json -> CM ()
processForwardedMsg author chatMsg = do
let body = LB . toStrict $ J . encode msg
rcvMsg @ RcvMessage { chatMsgEvent = ACME _ event } <- saveGroupFwdRcvMsg user groupId m author body chatMsg
case event of
2025-05-19 11:14:43 +01:00
XMsgNew mc -> 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 -> groupMessageFileDescription gInfo author sharedMsgId fileDescr
XMsgUpdate sharedMsgId mContent mentions ttl live msgScope -> memberCanSend author msgScope $ groupMessageUpdate gInfo author sharedMsgId mContent mentions msgScope rcvMsg msgTs ttl live
2024-12-20 16:54:24 +04:00
XMsgDel sharedMsgId memId -> groupMessageDelete gInfo author sharedMsgId memId rcvMsg msgTs
XMsgReact sharedMsgId ( Just memId ) reaction add -> groupMsgReaction gInfo author sharedMsgId memId reaction add rcvMsg msgTs
XFileCancel sharedMsgId -> xFileCancelGroup gInfo author sharedMsgId
XInfo p -> xInfoMember gInfo author p msgTs
2025-04-02 07:57:18 +00:00
XGrpMemNew memInfo msgScope -> xGrpMemNew gInfo author memInfo msgScope rcvMsg msgTs
2024-12-20 16:54:24 +04:00
XGrpMemRole memId memRole -> xGrpMemRole gInfo author memId memRole rcvMsg msgTs
2025-03-07 07:47:32 +00:00
XGrpMemDel memId withMessages -> xGrpMemDel gInfo author memId withMessages rcvMsg msgTs
2024-12-20 16:54:24 +04:00
XGrpLeave -> xGrpLeave gInfo author rcvMsg msgTs
XGrpDel -> xGrpDel gInfo author rcvMsg msgTs
XGrpInfo p' -> xGrpInfo gInfo author p' rcvMsg msgTs
XGrpPrefs ps' -> xGrpPrefs gInfo author ps'
_ -> messageError $ " x.grp.msg.forward: unsupported forwarded event " <> T . pack ( show $ toCMEventTag event )
createUnknownMember :: GroupInfo -> MemberId -> CM GroupMember
createUnknownMember gInfo memberId = do
2025-02-25 14:05:49 +04:00
let name = nameFromMemberId memberId
2024-12-20 16:54:24 +04:00
withStore $ \ db -> createNewUnknownGroupMember db vr user gInfo memberId name
directMsgReceived :: Contact -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
directMsgReceived ct conn @ Connection { connId } msgMeta msgRcpts = do
checkIntegrityCreateItem ( CDDirectRcv ct ) msgMeta ` catchChatError ` \ _ -> pure ()
forM_ msgRcpts $ \ MsgReceipt { agentMsgId , msgRcptStatus } -> do
withStore' $ \ db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
updateDirectItemStatus ct conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete
groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> CM ()
groupMsgReceived gInfo m conn @ Connection { connId } msgMeta msgRcpts = do
2025-04-21 15:17:21 +00:00
( gInfo' , m' , scopeInfo ) <- mkGroupChatScope gInfo m
2025-04-02 07:57:18 +00:00
checkIntegrityCreateItem ( CDGroupRcv gInfo' scopeInfo m' ) msgMeta ` catchChatError ` \ _ -> pure ()
2024-12-20 16:54:24 +04:00
forM_ msgRcpts $ \ MsgReceipt { agentMsgId , msgRcptStatus } -> do
withStore' $ \ db -> updateSndMsgDeliveryStatus db connId agentMsgId $ MDSSndRcvd msgRcptStatus
2025-04-02 07:57:18 +00:00
updateGroupItemsStatus gInfo' m' conn agentMsgId ( GSSRcvd msgRcptStatus ) Nothing
2024-12-20 16:54:24 +04:00
-- 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
2025-05-04 22:14:36 +01:00
unless ( null acis ) $ toView $ CEvtChatItemsStatusesUpdated user acis
2024-12-20 16:54:24 +04:00
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
2025-05-04 22:14:36 +01:00
unless ( null acis ) $ toView $ CEvtChatItemsStatusesUpdated user acis
2024-12-20 16:54:24 +04:00
where
ctItem = AChatItem SCTDirect SMDSnd ( DirectChat ct )
updateDirectItemsStatus' :: DB . Connection -> Contact -> Connection -> AgentMsgId -> CIStatus 'MDSnd -> ExceptT StoreError IO [ ChatItem 'CTDirect 'MDSnd ]
updateDirectItemsStatus' db ct @ Contact { contactId } Connection { connId } msgId newStatus = do
items <- liftIO $ getDirectChatItemsByAgentMsgId db user contactId connId msgId
catMaybes <$> mapM updateItem items
where
updateItem :: CChatItem 'CTDirect -> ExceptT StoreError IO ( Maybe ( ChatItem 'CTDirect 'MDSnd ) )
updateItem = \ case
( CChatItem SMDSnd ChatItem { meta = CIMeta { itemStatus = CISSndRcvd _ _ } } ) -> pure Nothing
( CChatItem SMDSnd ChatItem { meta = CIMeta { itemId , itemStatus } } )
| itemStatus == newStatus -> pure Nothing
| otherwise -> Just <$> updateDirectChatItemStatus db user ct itemId newStatus
_ -> pure Nothing
updateGroupMemSndStatus' :: DB . Connection -> ChatItemId -> GroupMemberId -> GroupSndStatus -> IO Bool
updateGroupMemSndStatus' db itemId groupMemberId newStatus =
runExceptT ( getGroupSndStatus db itemId groupMemberId ) >>= \ case
Right ( GSSRcvd _ ) -> pure False
Right memStatus
| memStatus == newStatus -> pure False
| otherwise -> updateGroupSndStatus db itemId groupMemberId newStatus $> True
_ -> pure False
updateGroupItemsStatus :: GroupInfo -> GroupMember -> Connection -> AgentMsgId -> GroupSndStatus -> Maybe Bool -> CM ()
updateGroupItemsStatus gInfo @ GroupInfo { groupId } GroupMember { groupMemberId } Connection { connId } msgId newMemStatus viaProxy_ = do
items <- withStore' ( \ db -> getGroupChatItemsByAgentMsgId db user groupId connId msgId )
cis <- catMaybes <$> withStore ( \ db -> mapM ( updateItem db ) items )
2025-04-02 07:57:18 +00:00
-- 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 : _ ) -> withStore $ \ db -> getGroupChatScopeInfoForItem db vr user gInfo ( chatItemId' ci )
_ -> pure Nothing
let acis = map ( gItem scopeInfo ) cis
2025-05-04 22:14:36 +01:00
unless ( null acis ) $ toView $ CEvtChatItemsStatusesUpdated user acis
2024-12-20 16:54:24 +04:00
where
2025-04-02 07:57:18 +00:00
gItem scopeInfo ci = AChatItem SCTGroup SMDSnd ( GroupChat gInfo scopeInfo ) ci
2024-12-20 16:54:24 +04:00
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