diff --git a/apps/simplex-directory-service/src/Directory/Events.hs b/apps/simplex-directory-service/src/Directory/Events.hs index 31a7e94aad..33b43a239b 100644 --- a/apps/simplex-directory-service/src/Directory/Events.hs +++ b/apps/simplex-directory-service/src/Directory/Events.hs @@ -72,7 +72,7 @@ crDirectoryEvent = \case CRDeletedMemberUser {groupInfo} -> Just $ DEServiceRemovedFromGroup groupInfo CRGroupDeleted {groupInfo} -> Just $ DEGroupDeleted groupInfo CRChatItemUpdated {chatItem = AChatItem _ SMDRcv (DirectChat ct) _} -> Just $ DEItemEditIgnored ct - CRChatItemDeleted {deletedChatItem = AChatItem _ SMDRcv (DirectChat ct) _, byUser = False} -> Just $ DEItemDeleteIgnored ct + CRChatItemsDeleted {chatItemDeletions = ((ChatItemDeletion (AChatItem _ SMDRcv (DirectChat ct) _) _) : _), byUser = False} -> Just $ DEItemDeleteIgnored ct CRNewChatItem {chatItem = AChatItem _ SMDRcv (DirectChat ct) ci@ChatItem {content = CIRcvMsgContent mc, meta = CIMeta {itemLive}}} -> Just $ case (mc, itemLive) of (MCText t, Nothing) -> DEContactCommand ct ciId $ fromRight err $ A.parseOnly (directoryCmdP <* A.endOfInput) $ T.dropWhileEnd isSpace t diff --git a/cabal.project b/cabal.project index 5129fe9c91..5f2c823561 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ constraints: zip +disable-bzip2 +disable-zstd source-repository-package type: git location: https://github.com/simplex-chat/simplexmq.git - tag: 83f8622b2397afe2635c8f60f1ec5f6fdc16ef7c + tag: 03ea151be5dce9a4b8683f9f28805bdc8ba66758 source-repository-package type: git diff --git a/scripts/nix/sha256map.nix b/scripts/nix/sha256map.nix index 35fc44f534..30390eeb9e 100644 --- a/scripts/nix/sha256map.nix +++ b/scripts/nix/sha256map.nix @@ -1,5 +1,5 @@ { - "https://github.com/simplex-chat/simplexmq.git"."83f8622b2397afe2635c8f60f1ec5f6fdc16ef7c" = "1dn7b0pjlk32crp943l6lz4r376nf444kjfi167mrv1pgccri6ns"; + "https://github.com/simplex-chat/simplexmq.git"."03ea151be5dce9a4b8683f9f28805bdc8ba66758" = "1gfkqzda6vw3fsd34c08jygwg0m5v211sm7v7jdvj0sx1p8428d4"; "https://github.com/simplex-chat/hs-socks.git"."a30cc7a79a08d8108316094f8f2f82a0c5e1ac51" = "0yasvnr7g91k76mjkamvzab2kvlb1g5pspjyjn2fr6v83swjhj38"; "https://github.com/simplex-chat/direct-sqlcipher.git"."f814ee68b16a9447fbb467ccc8f29bdd3546bfd9" = "1ql13f4kfwkbaq7nygkxgw84213i0zm7c1a8hwvramayxl38dq5d"; "https://github.com/simplex-chat/sqlcipher-simple.git"."a46bd361a19376c5211f1058908fc0ae6bf42446" = "1z0r78d8f0812kxbgsm735qf6xx8lvaz27k1a0b4a2m0sshpd5gl"; diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 752af26943..4298b60a67 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -41,7 +41,7 @@ import Data.Fixed (div') import Data.Functor (($>)) import Data.Functor.Identity import Data.Int (Int64) -import Data.List (find, foldl', isSuffixOf, partition, sortOn) +import Data.List (find, foldl', isSuffixOf, mapAccumL, partition, sortOn) import Data.List.NonEmpty (NonEmpty (..), nonEmpty, toList, (<|)) import qualified Data.List.NonEmpty as L import Data.Map.Strict (Map) @@ -407,8 +407,7 @@ startChatController mainApp enableSndFiles = do void $ forkIO $ startFilesToReceive users startCleanupManager void $ forkIO $ startExpireCIs users - else - when enableSndFiles $ startXFTP xftpStartSndWorkers + else when enableSndFiles $ startXFTP xftpStartSndWorkers pure a1 startXFTP startWorkers = do tmp <- readTVarIO =<< asks tempDirectory @@ -818,43 +817,96 @@ processChatCommand' vr = \case _ -> throwChatError CEInvalidChatItemUpdate CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> case cType of + APIDeleteChatItem (ChatRef cType chatId) itemIds mode -> withUser $ \user -> case cType of CTDirect -> withContactLock "deleteChatItem" chatId $ do - (ct, CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}}) <- withFastStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId - case (mode, msgDir, itemSharedMsgId, deletable) of - (CIDMInternal, _, _, _) -> deleteDirectCI user ct ci True False - (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do + ct <- withStore $ \db -> getContact db vr user chatId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getDirectCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + case mode of + CIDMInternal -> deleteDirectCIs user ct items True False + CIDMBroadcast -> do + assertDeletable items assertDirectAllowed user MDSnd ct XMsgDel_ - (SndMessage {msgId}, _) <- sendDirectContactMessage user ct (XMsgDel itemSharedMId Nothing) + let msgIds = itemsMsgIds items + events = map (\msgId -> XMsgDel msgId Nothing) msgIds + forM_ (L.nonEmpty events) $ \events' -> + sendDirectContactMessages user ct events' if featureAllowed SCFFullDelete forUser ct - then deleteDirectCI user ct ci True False - else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime - (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete + then deleteDirectCIs user ct items True False + else markDirectCIsDeleted user ct items True =<< liftIO getCurrentTime + where + getDirectCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTDirect)) + getDirectCI db itemId = runExceptT . withExceptT ChatErrorStore $ getDirectChatItem db user chatId itemId CTGroup -> withGroupLock "deleteChatItem" chatId $ do - Group gInfo ms <- withFastStore $ \db -> getGroup db vr user chatId - CChatItem msgDir ci@ChatItem {meta = CIMeta {itemSharedMsgId, deletable}} <- withFastStore $ \db -> getGroupChatItem db user chatId itemId - case (mode, msgDir, itemSharedMsgId, deletable) of - (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime - (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do + Group gInfo ms <- withStore $ \db -> getGroup db vr user chatId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + case mode of + CIDMInternal -> deleteGroupCIs user gInfo items True False Nothing =<< liftIO getCurrentTime + CIDMBroadcast -> do + assertDeletable items assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier - (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId Nothing - delGroupChatItem user gInfo ci msgId Nothing - (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete + let msgIds = itemsMsgIds items + events = L.nonEmpty $ map (`XMsgDel` Nothing) msgIds + mapM_ (sendGroupMessages user gInfo ms) events + delGroupChatItems user gInfo items Nothing + where + getGroupCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) + getGroupCI db itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user chatId itemId CTLocal -> do - (nf, CChatItem _ ci) <- withFastStore $ \db -> (,) <$> getNoteFolder db user chatId <*> getLocalChatItem db user chatId itemId - deleteLocalCI user nf ci True False + nf <- withStore $ \db -> getNoteFolder db user chatId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getLocalCI db) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + deleteLocalCIs user nf items True False + where + getLocalCI :: DB.Connection -> ChatItemId -> IO (Either ChatError (CChatItem 'CTLocal)) + getLocalCI db itemId = runExceptT . withExceptT ChatErrorStore $ getLocalChatItem db user chatId itemId CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" - APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do - Group gInfo@GroupInfo {membership} ms <- withFastStore $ \db -> getGroup db vr user gId - CChatItem _ ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}} <- withFastStore $ \db -> getGroupChatItem db user gId itemId - case (chatDir, itemSharedMsgId) of - (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do - when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete - assertUserGroupRole gInfo $ max GRAdmin memberRole - (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId - delGroupChatItem user gInfo ci msgId (Just membership) - (_, _) -> throwChatError CEInvalidChatItemDelete + where + assertDeletable :: forall c. ChatTypeI c => [CChatItem c] -> CM () + assertDeletable items = do + currentTs <- liftIO getCurrentTime + unless (all (itemDeletable currentTs) items) $ throwChatError CEInvalidChatItemDelete + where + itemDeletable :: UTCTime -> CChatItem c -> Bool + itemDeletable currentTs (CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, itemTs, itemDeleted}, content}) = + case msgDir of + -- We check with a 6 hour margin compared to CIMeta deletable to account for deletion on the border + SMDSnd -> isJust itemSharedMsgId && deletable' content itemDeleted itemTs (nominalDay + 6 * 3600) currentTs + SMDRcv -> False + itemsMsgIds :: [CChatItem c] -> [SharedMsgId] + itemsMsgIds = mapMaybe (\(CChatItem _ ChatItem {meta = CIMeta {itemSharedMsgId}}) -> itemSharedMsgId) + APIDeleteMemberChatItem gId itemIds -> withUser $ \user -> withGroupLock "deleteChatItem" gId $ do + Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db vr user gId + (errs, items) <- lift $ partitionEithers <$> withStoreBatch (\db -> map (getGroupCI db user) (L.toList itemIds)) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + assertDeletable gInfo items + assertUserGroupRole gInfo GRAdmin + let msgMemIds = itemsMsgMemIds gInfo items + events = L.nonEmpty $ map (\(msgId, memId) -> XMsgDel msgId (Just memId)) msgMemIds + mapM_ (sendGroupMessages user gInfo ms) events + delGroupChatItems user gInfo items (Just membership) + where + getGroupCI :: DB.Connection -> User -> ChatItemId -> IO (Either ChatError (CChatItem 'CTGroup)) + getGroupCI db user itemId = runExceptT . withExceptT ChatErrorStore $ getGroupChatItem db user gId itemId + assertDeletable :: GroupInfo -> [CChatItem 'CTGroup] -> CM () + assertDeletable GroupInfo {membership = GroupMember {memberRole = membershipMemRole}} items = + unless (all itemDeletable items) $ throwChatError CEInvalidChatItemDelete + where + itemDeletable :: CChatItem 'CTGroup -> Bool + itemDeletable (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = + case chatDir of + CIGroupRcv GroupMember {memberRole} -> membershipMemRole >= memberRole && isJust itemSharedMsgId + CIGroupSnd -> isJust itemSharedMsgId + itemsMsgMemIds :: GroupInfo -> [CChatItem 'CTGroup] -> [(SharedMsgId, MemberId)] + itemsMsgMemIds GroupInfo {membership = GroupMember {memberId = membershipMemId}} = mapMaybe itemMsgMemIds + where + itemMsgMemIds :: CChatItem 'CTGroup -> Maybe (SharedMsgId, MemberId) + itemMsgMemIds (CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) = + join <$> forM itemSharedMsgId $ \msgId -> Just $ case chatDir of + CIGroupRcv GroupMember {memberId} -> (msgId, memberId) + CIGroupSnd -> (msgId, membershipMemId) APIChatItemReaction (ChatRef cType chatId) itemId add reaction -> withUser $ \user -> case cType of CTDirect -> withContactLock "chatItemReaction" chatId $ @@ -1150,7 +1202,7 @@ processChatCommand' vr = \case filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo cancelFilesInProgress user filesInfo deleteFilesLocally filesInfo - withFastStore' $ \db -> deleteGroupCIs db user gInfo + withFastStore' $ \db -> deleteGroupChatItemsMessages db user gInfo membersToDelete <- withFastStore' $ \db -> getGroupMembersForExpiration db vr user gInfo forM_ membersToDelete $ \m -> withFastStore' $ \db -> deleteGroupMember db user m pure $ CRChatCleared user (AChatInfo SCTGroup $ GroupChat gInfo) @@ -1748,7 +1800,7 @@ processChatCommand' vr = \case Just (ctConns :: NonEmpty (Contact, Connection)) -> do let idsEvts = L.map ctSndEvent ctConns sndMsgs <- lift $ createSndMessages idsEvts - let msgReqs_ :: NonEmpty (Either ChatError MsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs + let msgReqs_ :: NonEmpty (Either ChatError ChatMsgReq) = L.zipWith (fmap . ctMsgReq) ctConns sndMsgs (errs, ctSndMsgs :: [(Contact, SndMessage)]) <- partitionEithers . L.toList . zipWith3' combineResults ctConns sndMsgs <$> deliverMessagesB msgReqs_ timestamp <- liftIO getCurrentTime @@ -1762,11 +1814,11 @@ processChatCommand' vr = \case _ -> ctConns ctSndEvent :: (Contact, Connection) -> (ConnOrGroupId, ChatMsgEvent 'Json) ctSndEvent (_, Connection {connId}) = (ConnectionId connId, XMsgNew $ MCSimple (extMsgContent mc Nothing)) - ctMsgReq :: (Contact, Connection) -> SndMessage -> MsgReq - ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, msgBody, msgId) + ctMsgReq :: (Contact, Connection) -> SndMessage -> ChatMsgReq + ctMsgReq (_, conn) SndMessage {msgId, msgBody} = (conn, MsgFlags {notification = hasNotification XMsgNew_}, msgBody, [msgId]) zipWith3' :: (a -> b -> c -> d) -> NonEmpty a -> NonEmpty b -> NonEmpty c -> NonEmpty d zipWith3' f ~(x :| xs) ~(y :| ys) ~(z :| zs) = f x y z :| zipWith3 f xs ys zs - combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError (Int64, PQEncryption) -> Either ChatError (Contact, SndMessage) + combineResults :: (Contact, Connection) -> Either ChatError SndMessage -> Either ChatError ([Int64], PQEncryption) -> Either ChatError (Contact, SndMessage) combineResults (ct, _) (Right msg') (Right _) = Right (ct, msg') combineResults _ (Left e) _ = Left e combineResults _ _ (Left e) = Left e @@ -1781,11 +1833,11 @@ processChatCommand' vr = \case DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg - processChatCommand $ APIDeleteChatItem chatRef deletedItemId CIDMBroadcast + processChatCommand $ APIDeleteChatItem chatRef (deletedItemId :| []) CIDMBroadcast DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do - (gId, mId) <- getGroupAndMemberId user gName mName + gId <- withFastStore $ \db -> getGroupIdByName db user gName deletedItemId <- withFastStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) deletedMsg - processChatCommand $ APIDeleteMemberChatItem gId mId deletedItemId + processChatCommand $ APIDeleteMemberChatItem gId (deletedItemId :| []) EditMessage chatName editedMsg msg -> withUser $ \user -> do chatRef <- getChatRef user chatName editedItemId <- getSentChatItemIdByText user chatRef editedMsg @@ -1904,7 +1956,7 @@ processChatCommand' vr = \case withGroupLock "blockForAll" groupId . procCmd $ do let mrs = if blocked then MRSBlocked else MRSUnrestricted event = XGrpMemRestrict bmMemberId MemberRestrictions {restriction = mrs} - (msg, _) <- sendGroupMessage' user gInfo remainingMembers event + msg <- sendGroupMessage' user gInfo remainingMembers event let ciContent = CISndGroupEvent $ SGEMemberBlocked memberId (fromLocalProfile bmp) blocked ci <- saveSndChatItem user (CDGroupSnd gInfo) msg ciContent toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) @@ -1941,7 +1993,7 @@ processChatCommand' vr = \case filesInfo <- withFastStore' $ \db -> getGroupFileInfo db user gInfo withGroupLock "leaveGroup" groupId . procCmd $ do cancelFilesInProgress user filesInfo - (msg, _) <- sendGroupMessage' user gInfo members XGrpLeave + msg <- sendGroupMessage' user gInfo members XGrpLeave ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) -- TODO delete direct connections that were unused @@ -2495,10 +2547,10 @@ processChatCommand' vr = \case mergedProfile' = userProfileToSend user' Nothing (Just ct') False ctSndEvent :: ChangedProfileContact -> (ConnOrGroupId, ChatMsgEvent 'Json) ctSndEvent ChangedProfileContact {mergedProfile', conn = Connection {connId}} = (ConnectionId connId, XInfo mergedProfile') - ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError MsgReq + ctMsgReq :: ChangedProfileContact -> Either ChatError SndMessage -> Either ChatError ChatMsgReq ctMsgReq ChangedProfileContact {conn} = fmap $ \SndMessage {msgId, msgBody} -> - (conn, MsgFlags {notification = hasNotification XInfo_}, msgBody, msgId) + (conn, MsgFlags {notification = hasNotification XInfo_}, msgBody, [msgId]) updateContactPrefs :: User -> Contact -> Preferences -> CM ChatResponse updateContactPrefs _ ct@Contact {activeConn = Nothing} _ = throwChatError $ CEContactNotActive ct updateContactPrefs user@User {userId} ct@Contact {activeConn = Just Connection {customUserProfileId}, userPreferences = contactUserPrefs} contactUserPrefs' @@ -2538,12 +2590,12 @@ processChatCommand' vr = \case when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved unless (memberActive membership) $ throwChatError CEGroupMemberNotActive - delGroupChatItem :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> CM ChatResponse - delGroupChatItem user gInfo ci msgId byGroupMember = do + delGroupChatItems :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Maybe GroupMember -> CM ChatResponse + delGroupChatItems user gInfo items byGroupMember = do deletedTs <- liftIO getCurrentTime if groupFeatureAllowed SGFFullDelete gInfo - then deleteGroupCI user gInfo ci True False byGroupMember deletedTs - else markGroupCIDeleted user gInfo ci msgId True byGroupMember deletedTs + then deleteGroupCIs user gInfo items True False byGroupMember deletedTs + else markGroupCIsDeleted user gInfo items True byGroupMember deletedTs updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> CM ChatResponse updateGroupProfileByName gName update = withUser $ \user -> do g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> @@ -2804,10 +2856,10 @@ processChatCommand' vr = \case (fInv_, ciFile_) <- L.unzip <$> setupSndFileTransfer g (length $ filter memberCurrent ms) timed_ <- sndGroupCITimed live gInfo itemTTL (msgContainer, quotedItem_) <- prepareGroupMsg user gInfo mc quotedItemId_ itemForwarded fInv_ timed_ live - (msg, groupSndResult) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) + (msg, r) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ itemForwarded timed_ live withFastStore' $ \db -> do - let GroupSndResult {sentTo, pending, forwarded} = groupSndResult + let GroupSndResult {sentTo, pending, forwarded} = mkGroupSndResult r createMemberSndStatuses db ci sentTo GSSNew createMemberSndStatuses db ci forwarded GSSForwarded createMemberSndStatuses db ci pending GSSInactive @@ -3668,12 +3720,12 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do vr <- chatVersionRange case cType of CTDirect -> do - (ct, CChatItem _ ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId - deleteDirectCI user ct ci True True >>= toView + (ct, ci) <- withStore $ \db -> (,) <$> getContact db vr user chatId <*> getDirectChatItem db user chatId itemId + deleteDirectCIs user ct [ci] True True >>= toView CTGroup -> do - (gInfo, CChatItem _ ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId + (gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db vr user chatId <*> getGroupChatItem db user chatId itemId deletedTs <- liftIO getCurrentTime - deleteGroupCI user gInfo ci True True Nothing deletedTs >>= toView + deleteGroupCIs user gInfo [ci] True True Nothing deletedTs >>= toView _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" startUpdatedTimedItemThread :: User -> ChatRef -> ChatItem c d -> ChatItem c d -> CM () @@ -4046,13 +4098,10 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = processINFOpqSupport conn pqSupport _conn' <- saveConnInfo conn connInfo pure () - MSG meta _msgFlags msgBody -> - -- TODO only acknowledge without saving message? - -- probably this branch is never executed, so there should be no reason - -- to save message if contact hasn't been created yet - chat item isn't created anyway - withAckMessage' "new contact msg" agentConnId meta $ - void $ - saveDirectRcvMSG conn meta msgBody + 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 @@ -4095,37 +4144,53 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = let MsgMeta {pqEncryption} = msgMeta (ct', conn') <- updateContactPQRcv user ct conn pqEncryption checkIntegrityCreateItem (CDDirectRcv ct') msgMeta `catchChatError` \_ -> pure () - (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody - let tag = toCMEventTag event - atomically $ writeTVar tags [tshow tag] - logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo - let ct'' = ct' {activeConn = Just conn''} :: Contact - assertDirectAllowed user MDRcv ct'' tag - case event of - XMsgNew mc -> newContentMessage ct'' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr - XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta - XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta - -- TODO discontinue XFile - XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta - XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId - XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName - XInfo p -> xInfo ct'' p - XDirectDel -> xDirectDel ct'' msg msgMeta - XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta - XInfoProbe probe -> xInfoProbe (COMContact ct'') probe - XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct'') probeHash - XInfoProbeOk probe -> xInfoProbeOk (COMContact ct'') probe - XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta - XCallOffer callId offer -> xCallOffer ct'' callId offer msg - XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg - XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg - XCallEnd callId -> xCallEnd ct'' callId msg - BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta - _ -> messageError $ "unsupported message: " <> T.pack (show event) - let Contact {chatSettings = ChatSettings {sendRcpts}} = ct'' - pure $ fromMaybe (sendRcptsContacts user) sendRcpts && hasDeliveryReceipt tag + forM_ aChatMsgs $ \case + Right (ACMsg _ chatMsg) -> + processEvent ct' conn' tags eInfo chatMsg `catchChatError` \e -> toView $ CRChatError (Just user) e + Left e -> do + atomically $ modifyTVar' tags ("error" :) + logInfo $ "contact msg=error " <> eInfo <> " " <> tshow e + toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) + checkSendRcpt ct' $ rights aChatMsgs -- not crucial to use ct'' from processEvent + where + aChatMsgs = parseChatMessages msgBody + processEvent :: Contact -> Connection -> TVar [Text] -> Text -> MsgEncodingI e => ChatMessage e -> CM () + processEvent ct' conn' tags eInfo chatMsg@ChatMessage {chatMsgEvent} = do + let tag = toCMEventTag chatMsgEvent + atomically $ modifyTVar' tags (tshow tag :) + logInfo $ "contact msg=" <> tshow tag <> " " <> eInfo + (conn'', msg@RcvMessage {chatMsgEvent = ACME _ event}) <- saveDirectRcvMSG conn' msgMeta msgBody chatMsg + let ct'' = ct' {activeConn = Just conn''} :: Contact + case event of + XMsgNew mc -> newContentMessage ct'' mc msg msgMeta + XMsgFileDescr sharedMsgId fileDescr -> messageFileDescription ct'' sharedMsgId fileDescr + XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct'' sharedMsgId mContent msg msgMeta ttl live + XMsgDel sharedMsgId _ -> messageDelete ct'' sharedMsgId msg msgMeta + XMsgReact sharedMsgId _ reaction add -> directMsgReaction ct'' sharedMsgId reaction add msg msgMeta + -- TODO discontinue XFile + XFile fInv -> processFileInvitation' ct'' fInv msg msgMeta + XFileCancel sharedMsgId -> xFileCancel ct'' sharedMsgId + XFileAcptInv sharedMsgId fileConnReq_ fName -> xFileAcptInv ct'' sharedMsgId fileConnReq_ fName + XInfo p -> xInfo ct'' p + XDirectDel -> xDirectDel ct'' msg msgMeta + XGrpInv gInv -> processGroupInvitation ct'' gInv msg msgMeta + XInfoProbe probe -> xInfoProbe (COMContact ct'') probe + XInfoProbeCheck probeHash -> xInfoProbeCheck (COMContact ct'') probeHash + XInfoProbeOk probe -> xInfoProbeOk (COMContact ct'') probe + XCallInv callId invitation -> xCallInv ct'' callId invitation msg msgMeta + XCallOffer callId offer -> xCallOffer ct'' callId offer msg + XCallAnswer callId answer -> xCallAnswer ct'' callId answer msg + XCallExtra callId extraInfo -> xCallExtra ct'' callId extraInfo msg + XCallEnd callId -> xCallEnd ct'' callId msg + BFileChunk sharedMsgId chunk -> bFileChunk ct'' sharedMsgId chunk msgMeta + _ -> messageError $ "unsupported message: " <> T.pack (show event) + checkSendRcpt :: Contact -> [AChatMessage] -> CM Bool + checkSendRcpt ct' aMsgs = do + let Contact {chatSettings = ChatSettings {sendRcpts}} = ct' + pure $ fromMaybe (sendRcptsContacts user) sendRcpts && any aChatMsgHasReceipt aMsgs + where + aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = + hasDeliveryReceipt (toCMEventTag chatMsgEvent) RCVD msgMeta msgRcpt -> withAckMessage' "contact rcvd" agentConnId msgMeta $ directMsgReceived ct conn msgMeta msgRcpt @@ -4529,7 +4594,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = atomically $ modifyTVar' tags ("error" :) logInfo $ "group msg=error " <> eInfo <> " " <> tshow e toView $ CRChatError (Just user) (ChatError . CEException $ "error parsing chat message: " <> e) - forwardMsg_ `catchChatError` (toView . CRChatError (Just user)) + forwardMsgs (rights aChatMsgs) `catchChatError` (toView . CRChatError (Just user)) checkSendRcpt $ rights aChatMsgs where aChatMsgs = parseChatMessages msgBody @@ -4581,27 +4646,24 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = where aChatMsgHasReceipt (ACMsg _ ChatMessage {chatMsgEvent}) = hasDeliveryReceipt (toCMEventTag chatMsgEvent) - forwardMsg_ :: CM () - forwardMsg_ = do + forwardMsgs :: [AChatMessage] -> CM () + forwardMsgs aMsgs = do let GroupMember {memberRole = membershipMemRole} = membership - when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ case aChatMsgs of - -- currently only a single message is forwarded - [Right (ACMsg _ chatMsg)] -> - forM_ (forwardedGroupMsg chatMsg) $ \chatMsg' -> 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) chatMsg' - msg = XGrpMsgForward memberId chatMsg' brokerTs - unless (null ms) . void $ - sendGroupMessage' user gInfo ms msg - _ -> pure () + when (membershipMemRole >= GRAdmin && not (blockedByAdmin m)) $ do + let forwardedMsgs = mapMaybe (\(ACMsg _ chatMsg) -> forwardedGroupMsg chatMsg) aMsgs + forM_ (L.nonEmpty forwardedMsgs) $ \forwardedMsgs' -> do + ChatConfig {highlyAvailable} <- asks config + -- members introduced to this invited member + introducedMembers <- + if memberCategory m == GCInviteeMember + then withStore' $ \db -> getForwardIntroducedMembers db vr user m highlyAvailable + else pure [] + -- invited members to which this member was introduced + invitedMembers <- withStore' $ \db -> getForwardInvitedMembers db vr user m highlyAvailable + let GroupMember {memberId} = m + ms = forwardedToGroupMembers (introducedMembers <> invitedMembers) forwardedMsgs' + events = L.map (\cm -> XGrpMsgForward memberId cm brokerTs) forwardedMsgs' + unless (null ms) $ sendGroupMessages user gInfo ms events RCVD msgMeta msgRcpt -> withAckMessage' "group rcvd" agentConnId msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -4647,8 +4709,8 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = -- [async agent commands] continuation on receiving OK when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () JOINED _ -> - -- [async agent commands] continuation on receiving JOINED - when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () + -- [async agent commands] continuation on receiving JOINED + when (corrId /= "") $ withCompletedCommand conn agentMsg $ \_cmdData -> pure () QCONT -> do continued <- continueSending connEntity conn when continued $ sendPendingGroupMessages user m conn @@ -5198,19 +5260,26 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> messageError "x.msg.update: contact attempted invalid message update" messageDelete :: Contact -> SharedMsgId -> RcvMessage -> MsgMeta -> CM () - messageDelete ct@Contact {contactId} sharedMsgId RcvMessage {msgId} msgMeta = do + messageDelete ct@Contact {contactId} sharedMsgId _rcvMessage msgMeta = do deleteRcvChatItem `catchCINotFound` (toView . CRChatItemDeletedNotFound user ct) where brokerTs = metaBrokerTs msgMeta deleteRcvChatItem = do - CChatItem msgDir ci <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId + cci@(CChatItem msgDir ci) <- withStore $ \db -> getDirectChatItemBySharedMsgId db user contactId sharedMsgId case msgDir of - SMDRcv -> - if featureAllowed SCFFullDelete forContact ct - then deleteDirectCI user ct ci False False >>= toView - else markDirectCIDeleted user ct ci msgId False brokerTs >>= toView + SMDRcv + | rcvItemDeletable ci brokerTs -> + if featureAllowed SCFFullDelete forContact ct + then deleteDirectCIs user ct [cci] False False >>= toView + else markDirectCIsDeleted user ct [cci] False brokerTs >>= toView + | otherwise -> messageError "x.msg.del: contact attempted invalid message delete" SMDSnd -> messageError "x.msg.del: contact attempted invalid message delete" + rcvItemDeletable :: ChatItem c d -> UTCTime -> Bool + rcvItemDeletable ChatItem {meta = CIMeta {itemTs, itemDeleted}} brokerTs = + -- 78 hours margin to account for possible sending delay + diffUTCTime brokerTs itemTs < (78 * 3600) && isNothing itemDeleted + directMsgReaction :: Contact -> SharedMsgId -> MsgReaction -> Bool -> RcvMessage -> MsgMeta -> CM () directMsgReaction ct sharedMsgId reaction add RcvMessage {msgId} MsgMeta {broker = (_, brokerTs)} = do when (featureAllowed SCFReactions forContact ct) $ do @@ -5288,7 +5357,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = ci <- createNonLive file_ ci' <- withStore' $ \db -> markGroupCIBlockedByAdmin db user gInfo ci groupMsgToView gInfo ci' - applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt} + applyModeration CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, moderatedAt} | moderatorRole < GRAdmin || moderatorRole < memberRole = createContentItem | groupFeatureAllowed SGFFullDelete gInfo = do @@ -5298,7 +5367,7 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = | otherwise = do file_ <- processFileInv ci <- createNonLive file_ - toView =<< markGroupCIDeleted user gInfo ci createdByMsgId False (Just moderator) moderatedAt + toView =<< markGroupCIsDeleted user gInfo [CChatItem SMDRcv ci] False (Just moderator) moderatedAt createNonLive file_ = saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ brokerTs (CIRcvMsgContent content) (snd <$> file_) timed' False createContentItem = do @@ -5357,30 +5426,40 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} brokerTs = do let msgMemberId = fromMaybe memberId sndMemberId_ withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case - Right (CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of - CIGroupRcv mem - | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView - | otherwise -> deleteMsg mem ci - CIGroupSnd -> deleteMsg membership ci + Right cci@(CChatItem _ ci@ChatItem {chatDir}) -> case chatDir of + CIGroupRcv mem -> case sndMemberId_ of + -- regular deletion + Nothing + | sameMemberId memberId mem && msgMemberId == memberId && rcvItemDeletable ci brokerTs -> + delete cci Nothing >>= toView + | otherwise -> + messageError "x.msg.del: member attempted invalid message delete" + -- moderation (not limited by time) + Just _ + | sameMemberId memberId mem && msgMemberId == memberId -> + delete cci (Just m) >>= toView + | otherwise -> + moderate mem cci + CIGroupSnd -> moderate membership cci Left e | msgMemberId == memberId -> messageError $ "x.msg.del: message not found, " <> tshow e | senderRole < GRAdmin -> messageError $ "x.msg.del: message not found, message of another member with insufficient member permissions, " <> tshow e | otherwise -> withStore' $ \db -> createCIModeration db gInfo m msgMemberId sharedMsgId msgId brokerTs where - deleteMsg :: MsgDirectionI d => GroupMember -> ChatItem 'CTGroup d -> CM () - deleteMsg mem ci = case sndMemberId_ of + moderate :: GroupMember -> CChatItem 'CTGroup -> CM () + moderate mem cci = case sndMemberId_ of Just sndMemberId - | sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView + | sameMemberId sndMemberId mem -> checkRole mem $ delete cci (Just m) >>= toView | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" _ -> messageError "x.msg.del: message of another member without memberId" checkRole GroupMember {memberRole} a | senderRole < GRAdmin || senderRole < memberRole = messageError "x.msg.del: message of another member with insufficient member permissions" | otherwise = a - delete :: MsgDirectionI d => ChatItem 'CTGroup d -> Maybe GroupMember -> CM ChatResponse - delete ci byGroupMember - | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember brokerTs - | otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember brokerTs + delete :: CChatItem 'CTGroup -> Maybe GroupMember -> CM ChatResponse + delete cci byGroupMember + | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCIs user gInfo [cci] False False byGroupMember brokerTs + | otherwise = markGroupCIsDeleted user gInfo [cci] False byGroupMember brokerTs -- TODO remove once XFile is discontinued processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> CM () @@ -5556,9 +5635,9 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage = _ -> messageError "x.file.acpt.inv: member connection is not active" else messageError "x.file.acpt.inv: fileName is different from expected" - groupMsgToView :: GroupInfo -> ChatItem 'CTGroup 'MDRcv -> CM () + groupMsgToView :: forall d. MsgDirectionI d => GroupInfo -> ChatItem 'CTGroup d -> CM () groupMsgToView gInfo ci = - toView $ CRNewChatItem user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) + toView $ CRNewChatItem user (AChatItem SCTGroup (msgDirection @d) (GroupChat gInfo) ci) processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> CM () processGroupInvitation ct inv msg msgMeta = do @@ -6660,6 +6739,22 @@ deleteOrUpdateMemberRecord user@User {userId} member = Just _ -> updateGroupMemberStatus db userId member GSMemRemoved Nothing -> deleteGroupMember db user member +sendDirectContactMessages :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM () +sendDirectContactMessages user ct events = do + Connection {connChatVersion = v} <- liftEither $ contactSendConn_ ct + if v >= batchSend2Version + then sendDirectContactMessages' user ct events + else mapM_ (void . sendDirectContactMessage user ct) events + +sendDirectContactMessages' :: MsgEncodingI e => User -> Contact -> NonEmpty (ChatMsgEvent e) -> CM () +sendDirectContactMessages' user ct events = do + conn@Connection {connId} <- liftEither $ contactSendConn_ ct + let idsEvts = L.map (ConnectionId connId,) events + msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} + (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts + unless (null errs) $ toView $ CRChatErrors (Just user) errs + mapM_ (batchSendConnMessages user conn msgFlags) (L.nonEmpty msgs) + sendDirectContactMessage :: MsgEncodingI e => User -> Contact -> ChatMsgEvent e -> CM (SndMessage, Int64) sendDirectContactMessage user ct chatMsgEvent = do conn@Connection {connId} <- liftEither $ contactSendConn_ ct @@ -6716,38 +6811,23 @@ sendGroupMemberMessages user conn events groupId = do (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts unless (null errs) $ toView $ CRChatErrors (Just user) errs forM_ (L.nonEmpty msgs) $ \msgs' -> - batchSendGroupMemberMessages user conn msgs' + batchSendConnMessages user conn MsgFlags {notification = True} msgs' -batchSendGroupMemberMessages :: User -> Connection -> NonEmpty SndMessage -> CM () -batchSendGroupMemberMessages user conn msgs = do - -- TODO v5.7 based on version (?) - -- let shouldCompress = False - -- let batched = if shouldCompress then batchSndMessagesBinary msgs' else batchSndMessagesJSON msgs' +batchSendConnMessages :: User -> Connection -> MsgFlags -> NonEmpty SndMessage -> CM () +batchSendConnMessages user conn msgFlags msgs = do let batched = batchSndMessagesJSON msgs let (errs', msgBatches) = partitionEithers batched -- shouldn't happen, as large messages would have caused createNewSndMessage to throw SELargeMsg unless (null errs') $ toView $ CRChatErrors (Just user) errs' - forM_ msgBatches $ \batch -> - processSndMessageBatch conn batch `catchChatError` (toView . CRChatError (Just user)) + forM_ (L.nonEmpty msgBatches) $ \msgBatches' -> do + let msgReq = L.map (msgBatchReq conn msgFlags) msgBatches' + void $ deliverMessages msgReq -processSndMessageBatch :: Connection -> MsgBatch -> CM () -processSndMessageBatch conn@Connection {connId} (MsgBatch batchBody sndMsgs) = do - (agentMsgId, _pqEnc) <- withAgent $ \a -> sendMessage a (aConnId conn) PQEncOff MsgFlags {notification = True} batchBody - let sndMsgDelivery = SndMsgDelivery {connId, agentMsgId} - lift . void . withStoreBatch' $ \db -> map (\SndMessage {msgId} -> createSndMsgDelivery db sndMsgDelivery msgId) sndMsgs - --- TODO v5.7 update batching for groups batchSndMessagesJSON :: NonEmpty SndMessage -> [Either ChatError MsgBatch] batchSndMessagesJSON = batchMessages maxEncodedMsgLength . L.toList --- batchSndMessagesBinary :: NonEmpty SndMessage -> [Either ChatError MsgBatch] --- batchSndMessagesBinary msgs = map toMsgBatch . SMP.batchTransmissions_ (maxEncodedMsgLength) $ L.zip (map compress1 msgs) msgs --- where --- toMsgBatch :: SMP.TransportBatch SndMessage -> Either ChatError MsgBatch --- toMsgBatch = \case --- SMP.TBTransmissions combined _n sms -> Right $ MsgBatch (markCompressedBatch combined) sms --- SMP.TBError tbe SndMessage {msgId} -> Left . ChatError $ CEInternalError (show tbe <> " " <> show msgId) --- SMP.TBTransmission {} -> Left . ChatError $ CEInternalError "batchTransmissions_ didn't produce a batch" +msgBatchReq :: Connection -> MsgFlags -> MsgBatch -> ChatMsgReq +msgBatchReq conn msgFlags (MsgBatch batchBody sndMsgs) = (conn, msgFlags, batchBody, map (\SndMessage {msgId} -> msgId) sndMsgs) encodeConnInfo :: MsgEncodingI e => ChatMsgEvent e -> CM ByteString encodeConnInfo chatMsgEvent = do @@ -6774,19 +6854,23 @@ deliverMessage conn cmEventTag msgBody msgId = do deliverMessage' :: Connection -> MsgFlags -> MsgBody -> MessageId -> CM (Int64, PQEncryption) deliverMessage' conn msgFlags msgBody msgId = - deliverMessages ((conn, msgFlags, msgBody, msgId) :| []) >>= \case - r :| [] -> liftEither r + deliverMessages ((conn, msgFlags, msgBody, [msgId]) :| []) >>= \case + r :| [] -> case r of + Right ([deliveryId], pqEnc) -> pure (deliveryId, pqEnc) + Right (deliveryIds, _) -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 delivery id, got " <> show (length deliveryIds) + Left e -> throwError e rs -> throwChatError $ CEInternalError $ "deliverMessage: expected 1 result, got " <> show (length rs) -type MsgReq = (Connection, MsgFlags, MsgBody, MessageId) +-- [MessageId] - SndMessage ids inside MsgBatch, or single message id +type ChatMsgReq = (Connection, MsgFlags, MsgBody, [MessageId]) -deliverMessages :: NonEmpty MsgReq -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessages :: NonEmpty ChatMsgReq -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) deliverMessages msgs = deliverMessagesB $ L.map Right msgs -deliverMessagesB :: NonEmpty (Either ChatError MsgReq) -> CM (NonEmpty (Either ChatError (Int64, PQEncryption))) +deliverMessagesB :: NonEmpty (Either ChatError ChatMsgReq) -> CM (NonEmpty (Either ChatError ([Int64], PQEncryption))) deliverMessagesB msgReqs = do msgReqs' <- liftIO compressBodies - sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` L.map toAgent msgReqs') + sent <- L.zipWith prepareBatch msgReqs' <$> withAgent (`sendMessagesB` snd (mapAccumL toAgent Nothing msgReqs')) lift . void $ withStoreBatch' $ \db -> map (updatePQSndEnabled db) (rights . L.toList $ sent) lift . withStoreBatch $ \db -> L.map (bindRight $ createDelivery db) sent where @@ -6802,16 +6886,20 @@ deliverMessagesB msgReqs = do when (B.length msgBody' > maxCompressedMsgLength) $ throwError $ ChatError $ CEException "large compressed message" pure (conn, msgFlags, msgBody', msgId) _ -> pure mr - toAgent = \case - Right (conn@Connection {pqEncryption}, msgFlags, msgBody, _msgId) -> Right (aConnId conn, pqEncryption, msgFlags, msgBody) - Left _ce -> Left (AP.INTERNAL "ChatError, skip") -- as long as it is Left, the agent batchers should just step over it + toAgent prev = \case + Right (conn@Connection {connId, pqEncryption}, msgFlags, msgBody, _msgIds) -> + let cId = case prev of + Just prevId | prevId == connId -> "" + _ -> aConnId conn + in (Just connId, Right (cId, pqEncryption, msgFlags, msgBody)) + Left _ce -> (prev, Left (AP.INTERNAL "ChatError, skip")) -- as long as it is Left, the agent batchers should just step over it prepareBatch (Right req) (Right ar) = Right (req, ar) prepareBatch (Left ce) _ = Left ce -- restore original ChatError prepareBatch _ (Left ae) = Left $ ChatErrorAgent ae Nothing - createDelivery :: DB.Connection -> (MsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError (Int64, PQEncryption)) - createDelivery db ((Connection {connId}, _, _, msgId), (agentMsgId, pqEnc')) = - Right . (,pqEnc') <$> createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId}) msgId - updatePQSndEnabled :: DB.Connection -> (MsgReq, (AgentMsgId, PQEncryption)) -> IO () + createDelivery :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO (Either ChatError ([Int64], PQEncryption)) + createDelivery db ((Connection {connId}, _, _, msgIds), (agentMsgId, pqEnc')) = do + Right . (,pqEnc') <$> mapM (createSndMsgDelivery db (SndMsgDelivery {connId, agentMsgId})) msgIds + updatePQSndEnabled :: DB.Connection -> (ChatMsgReq, (AgentMsgId, PQEncryption)) -> IO () updatePQSndEnabled db ((Connection {connId, pqSndEnabled}, _, _, _), (_, pqSndEnabled')) = case (pqSndEnabled, pqSndEnabled') of (Just b, b') | b' /= b -> updatePQ @@ -6822,11 +6910,11 @@ deliverMessagesB msgReqs = do -- TODO combine profile update and message into one batch -- Take into account that it may not fit, and that we currently don't support sending multiple messages to the same connection in one call. -sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResult) +sendGroupMessage :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResultData) sendGroupMessage user gInfo members chatMsgEvent = do when shouldSendProfileUpdate $ sendProfileUpdate `catchChatError` (toView . CRChatError (Just user)) - sendGroupMessage' user gInfo members chatMsgEvent + sendGroupMessage_ user gInfo members chatMsgEvent where User {profile = p, userMemberProfileUpdatedAt} = user GroupInfo {userMemberProfileSentAt} = gInfo @@ -6844,32 +6932,59 @@ sendGroupMessage user gInfo members chatMsgEvent = do currentTs <- liftIO getCurrentTime withStore' $ \db -> updateUserMemberProfileSentAt db user gInfo currentTs +type GroupSndResultData = (([Either ChatError ([Int64], PQEncryption)], [(GroupMember, Connection)]), ([Either ChatError ()], [GroupMember]), [GroupMember]) + data GroupSndResult = GroupSndResult { sentTo :: [GroupMember], pending :: [GroupMember], forwarded :: [GroupMember] } -sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResult) -sendGroupMessage' user gInfo@GroupInfo {groupId} members chatMsgEvent = do - msg@SndMessage {msgId, msgBody} <- createSndMessage chatMsgEvent (GroupId groupId) - recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) - let msgFlags = MsgFlags {notification = hasNotification $ toCMEventTag chatMsgEvent} - (toSend, pending, forwarded, _, dups) = foldr addMember ([], [], [], S.empty, 0 :: Int) recipientMembers +sendGroupMessage' :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM SndMessage +sendGroupMessage' user gInfo members chatMsgEvent = fst <$> sendGroupMessage_ user gInfo members chatMsgEvent + +sendGroupMessage_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> ChatMsgEvent e -> CM (SndMessage, GroupSndResultData) +sendGroupMessage_ user gInfo members chatMsgEvent = + sendGroupMessages_ user gInfo members (chatMsgEvent :| []) >>= \case + (msg :| [], r) -> pure (msg, r) + _ -> throwChatError $ CEInternalError "sendGroupMessage': expected 1 message" + +sendGroupMessages :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM () +sendGroupMessages user gInfo members events = void $ sendGroupMessages_ user gInfo members events + +mkGroupSndResult :: GroupSndResultData -> GroupSndResult +mkGroupSndResult ((delivered, sentTo), (stored, pending), forwarded) = + GroupSndResult + { sentTo = filterSent' delivered sentTo fst, + pending = filterSent' stored pending id, + forwarded + } + where + -- TODO in theory this could deduplicate members and keep results only when ... some sent? or all sent? + -- This is not important, as it is not used in batch calls + filterSent' :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember] + filterSent' rs ms mem = [mem m | (Right _, m) <- zip rs ms] + +sendGroupMessages_ :: MsgEncodingI e => User -> GroupInfo -> [GroupMember] -> NonEmpty (ChatMsgEvent e) -> CM (NonEmpty SndMessage, GroupSndResultData) +sendGroupMessages_ user gInfo@GroupInfo {groupId} members events = do + let idsEvts = L.map (GroupId groupId,) events + (errs, msgs) <- lift $ partitionEithers . L.toList <$> createSndMessages idsEvts + unless (null errs) $ toView $ CRChatErrors (Just user) errs + case L.nonEmpty msgs of + Nothing -> throwChatError $ CEInternalError "sendGroupMessages: no messages created" + Just msgs' -> do + recipientMembers <- liftIO $ shuffleMembers (filter memberCurrent members) + let msgFlags = MsgFlags {notification = any (hasNotification . toCMEventTag) events} + (toSendSeparate, toSendBatched, pending, forwarded, _, dups) = + foldr addMember ([], [], [], [], S.empty, 0 :: Int) recipientMembers + when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members" -- TODO PQ either somehow ensure that group members connections cannot have pqSupport/pqEncryption or pass Off's here - msgReqs = map (\(_, conn) -> (conn, msgFlags, msgBody, msgId)) toSend - when (dups /= 0) $ logError $ "sendGroupMessage: " <> tshow dups <> " duplicate members" - delivered <- maybe (pure []) (fmap L.toList . deliverMessages) $ L.nonEmpty msgReqs - let errors = lefts delivered - unless (null errors) $ toView $ CRChatErrors (Just user) errors - stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) pending - let gsr = - GroupSndResult - { sentTo = filterSent delivered toSend fst, - pending = filterSent stored pending id, - forwarded - } - pure (msg, gsr) + let msgReqs = prepareMsgReqs msgFlags msgs' toSendSeparate toSendBatched + delivered <- maybe (pure []) (fmap L.toList . deliverMessages) $ L.nonEmpty msgReqs + let errors = lefts delivered + unless (null errors) $ toView $ CRChatErrors (Just user) errors + stored <- lift . withStoreBatch' $ \db -> map (\m -> createPendingMsgs db m msgs') pending + pure (msgs', ((delivered, toSendSeparate <> toSendBatched), (stored, pending), forwarded)) where shuffleMembers :: [GroupMember] -> IO [GroupMember] shuffleMembers ms = do @@ -6877,31 +6992,52 @@ sendGroupMessage' user gInfo@GroupInfo {groupId} members chatMsgEvent = do liftM2 (<>) (shuffle adminMs) (shuffle otherMs) where isAdmin GroupMember {memberRole} = memberRole >= GRAdmin - addMember m acc@(toSend, pending, forwarded, !mIds, !dups) = case memberSendAction gInfo chatMsgEvent members m of - Just a - | mId `S.member` mIds -> (toSend, pending, forwarded, mIds, dups + 1) - | otherwise -> case a of - MSASend conn -> ((m, conn) : toSend, pending, forwarded, mIds', dups) - MSAPending -> (toSend, m : pending, forwarded, mIds', dups) - MSAForwarded -> (toSend, pending, m : forwarded, mIds', dups) - Nothing -> acc + addMember m acc@(toSendSeparate, toSendBatched, pending, forwarded, !mIds, !dups) = + case memberSendAction gInfo events members m of + Just a + | mId `S.member` mIds -> (toSendSeparate, toSendBatched, pending, forwarded, mIds, dups + 1) + | otherwise -> case a of + MSASend conn -> ((m, conn) : toSendSeparate, toSendBatched, pending, forwarded, mIds', dups) + MSASendBatched conn -> (toSendSeparate, (m, conn) : toSendBatched, pending, forwarded, mIds', dups) + MSAPending -> (toSendSeparate, toSendBatched, m : pending, forwarded, mIds', dups) + MSAForwarded -> (toSendSeparate, toSendBatched, pending, m : forwarded, mIds', dups) + Nothing -> acc where mId = groupMemberId' m mIds' = S.insert mId mIds - filterSent :: [Either ChatError a] -> [mem] -> (mem -> GroupMember) -> [GroupMember] - filterSent rs ms mem = [mem m | (Right _, m) <- zip rs ms] + prepareMsgReqs :: MsgFlags -> NonEmpty SndMessage -> [(GroupMember, Connection)] -> [(GroupMember, Connection)] -> [ChatMsgReq] + prepareMsgReqs msgFlags msgs toSendSeparate toSendBatched = do + let msgReqsSeparate = foldr (\(_, conn) reqs -> foldr (\msg -> (sndMessageReq conn msg :)) reqs msgs) [] toSendSeparate + batched = batchSndMessagesJSON msgs + -- _errs shouldn't happen, as large messages would have caused createNewSndMessage to throw SELargeMsg + (_errs, msgBatches) = partitionEithers batched + case L.nonEmpty msgBatches of + Just msgBatches' -> do + let msgReqsBatched = foldr (\(_, conn) reqs -> foldr (\batch -> (msgBatchReq conn msgFlags batch :)) reqs msgBatches') [] toSendBatched + msgReqsSeparate <> msgReqsBatched + Nothing -> msgReqsSeparate + where + sndMessageReq :: Connection -> SndMessage -> ChatMsgReq + sndMessageReq conn SndMessage {msgId, msgBody} = (conn, msgFlags, msgBody, [msgId]) + createPendingMsgs :: DB.Connection -> GroupMember -> NonEmpty SndMessage -> IO () + createPendingMsgs db m = mapM_ (\SndMessage {msgId} -> createPendingGroupMessage db (groupMemberId' m) msgId Nothing) -data MemberSendAction = MSASend Connection | MSAPending | MSAForwarded +data MemberSendAction = MSASend Connection | MSASendBatched Connection | MSAPending | MSAForwarded -memberSendAction :: GroupInfo -> ChatMsgEvent e -> [GroupMember] -> GroupMember -> Maybe MemberSendAction -memberSendAction gInfo chatMsgEvent members m = case memberConn m of +memberSendAction :: GroupInfo -> NonEmpty (ChatMsgEvent e) -> [GroupMember] -> GroupMember -> Maybe MemberSendAction +memberSendAction gInfo events members m@GroupMember {memberRole} = case memberConn m of Nothing -> pendingOrForwarded Just conn@Connection {connStatus} | connDisabled conn || connStatus == ConnDeleted -> Nothing | connInactive conn -> Just MSAPending - | connStatus == ConnSndReady || connStatus == ConnReady -> Just (MSASend conn) + | connStatus == ConnSndReady || connStatus == ConnReady -> sendBatchedOrSeparate conn | otherwise -> pendingOrForwarded where + sendBatchedOrSeparate conn + -- admin doesn't support batch forwarding - send messages separately so that admin can forward one by one + | memberRole >= GRAdmin && not (m `supportsVersion` batchSend2Version) = Just (MSASend conn) + -- either member is not admin, or admin supports batched forwarding + | otherwise = Just (MSASendBatched conn) pendingOrForwarded = case memberCategory m of GCUserMember -> Nothing -- shouldn't happen GCInviteeMember -> Just MSAPending @@ -6910,8 +7046,8 @@ memberSendAction gInfo chatMsgEvent members m = case memberConn m of GCPostMember -> forwardSupportedOrPending (invitedByGroupMemberId m) where forwardSupportedOrPending invitingMemberId_ - | membersSupport && isForwardedGroupMsg chatMsgEvent = Just MSAForwarded - | isXGrpMsgForward = Nothing + | membersSupport && all isForwardedGroupMsg events = Just MSAForwarded + | any isXGrpMsgForward events = Nothing | otherwise = Just MSAPending where membersSupport = @@ -6923,7 +7059,7 @@ memberSendAction gInfo chatMsgEvent members m = case memberConn m of Just invitingMember -> invitingMember `supportsVersion` groupForwardVersion Nothing -> False Nothing -> False - isXGrpMsgForward = case chatMsgEvent of + isXGrpMsgForward event = case event of XGrpMsgForward {} -> True _ -> False @@ -6933,8 +7069,9 @@ sendGroupMemberMessage user gInfo@GroupInfo {groupId} m@GroupMember {groupMember messageMember msg `catchChatError` (toView . CRChatError (Just user)) where messageMember :: SndMessage -> CM () - messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo chatMsgEvent [m] m) $ \case + messageMember SndMessage {msgId, msgBody} = forM_ (memberSendAction gInfo (chatMsgEvent :| []) [m] m) $ \case MSASend conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver + MSASendBatched conn -> deliverMessage conn (toCMEventTag chatMsgEvent) msgBody msgId >> postDeliver MSAPending -> withStore' $ \db -> createPendingGroupMessage db groupMemberId msgId introId_ MSAForwarded -> pure () @@ -6944,7 +7081,7 @@ sendPendingGroupMessages user GroupMember {groupMemberId} conn = do pgms <- withStore' $ \db -> getPendingGroupMessages db groupMemberId forM_ (L.nonEmpty pgms) $ \pgms' -> do let msgs = L.map (\(sndMsg, _, _) -> sndMsg) pgms' - batchSendGroupMemberMessages user conn msgs + batchSendConnMessages user conn MsgFlags {notification = True} msgs lift . void . withStoreBatch' $ \db -> L.map (\SndMessage {msgId} -> deletePendingGroupMessage db groupMemberId msgId) msgs lift . void . withStoreBatch' $ \db -> L.map (\(_, tag, introId_) -> updateIntro_ db tag introId_) pgms' where @@ -6953,19 +7090,14 @@ sendPendingGroupMessages user GroupMember {groupMemberId} conn = do (ACMEventTag _ XGrpMemFwd_, Just introId) -> updateIntroStatus db introId GMIntroInvForwarded _ -> pure () --- TODO [batch send] refactor direct message processing same as groups (e.g. checkIntegrity before processing) -saveDirectRcvMSG :: Connection -> MsgMeta -> MsgBody -> CM (Connection, RcvMessage) -saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody = - case parseChatMessages msgBody of - [Right (ACMsg _ ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent})] -> do - conn' <- updatePeerChatVRange conn chatVRange - let agentMsgId = fst $ recipient agentMsgMeta - newMsg = NewRcvMessage {chatMsgEvent, msgBody} - rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} - msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing - pure (conn', msg) - [Left e] -> error $ "saveDirectRcvMSG: error parsing chat message: " <> e - _ -> error "saveDirectRcvMSG: batching not supported" +saveDirectRcvMSG :: MsgEncodingI e => Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (Connection, RcvMessage) +saveDirectRcvMSG conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do + conn' <- updatePeerChatVRange conn chatVRange + let agentMsgId = fst $ recipient agentMsgMeta + newMsg = NewRcvMessage {chatMsgEvent, msgBody} + rcvMsgDelivery = RcvMsgDelivery {connId, agentMsgId, agentMsgMeta} + msg <- withStore $ \db -> createNewMessageAndRcvMsgDelivery db (ConnectionId connId) newMsg sharedMsgId_ rcvMsgDelivery Nothing + pure (conn', msg) saveGroupRcvMsg :: MsgEncodingI e => User -> GroupId -> GroupMember -> Connection -> MsgMeta -> MsgBody -> ChatMessage e -> CM (GroupMember, Connection, RcvMessage) saveGroupRcvMsg user groupId authorMember conn@Connection {connId} agentMsgMeta msgBody ChatMessage {chatVRange, msgId = sharedMsgId_, chatMsgEvent} = do @@ -7036,59 +7168,85 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemForwarded itemTimed l meta = mkCIMeta ciId content itemText itemStatus Nothing sharedMsgId itemForwarded Nothing False itemTimed (justTrue live) currentTs itemTs forwardedByMember currentTs currentTs in ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, reactions = [], file} -deleteDirectCI :: MsgDirectionI d => User -> Contact -> ChatItem 'CTDirect d -> Bool -> Bool -> CM ChatResponse -deleteDirectCI user ct ci@ChatItem {file} byUser timed = do - deleteCIFile user file - withStore' $ \db -> deleteDirectChatItem db user ct ci - pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDirection (DirectChat ct) ci) Nothing byUser timed - -deleteGroupCI :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse -deleteGroupCI user gInfo ci@ChatItem {file} byUser timed byGroupMember_ deletedTs = do - deleteCIFile user file - toCi <- withStore' $ \db -> - case byGroupMember_ of - Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing - Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs - pure $ CRChatItemDeleted user (gItem ci) (gItem <$> toCi) byUser timed +deleteDirectCIs :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> Bool -> CM ChatResponse +deleteDirectCIs user ct items byUser timed = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteCIFiles user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed where - gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo) + deleteItem db (CChatItem md ci) = do + deleteDirectChatItem db user ct ci + pure $ contactDeletion md ct ci Nothing -deleteLocalCI :: MsgDirectionI d => User -> NoteFolder -> ChatItem 'CTLocal d -> Bool -> Bool -> CM ChatResponse -deleteLocalCI user nf ci@ChatItem {file = file_} byUser timed = do - forM_ file_ $ \file -> do - let filesInfo = [mkCIFileInfo file] - deleteFilesLocally filesInfo - withStore' $ \db -> deleteLocalChatItem db user nf ci - pure $ CRChatItemDeleted user (AChatItem SCTLocal msgDirection (LocalChat nf) ci) Nothing byUser timed - -deleteCIFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> CM () -deleteCIFile user file_ = - forM_ file_ $ \file -> do - let filesInfo = [mkCIFileInfo file] - cancelFilesInProgress user filesInfo - deleteFilesLocally filesInfo - -markDirectCIDeleted :: MsgDirectionI d => User -> Contact -> ChatItem 'CTDirect d -> MessageId -> Bool -> UTCTime -> CM ChatResponse -markDirectCIDeleted user ct ci@ChatItem {file} msgId byUser deletedTs = do - cancelCIFile user file - ci' <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId deletedTs - pure $ CRChatItemDeleted user (ctItem ci) (Just $ ctItem ci') byUser False +deleteGroupCIs :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse +deleteGroupCIs user gInfo items byUser timed byGroupMember_ deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteCIFiles user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed where - ctItem = AChatItem SCTDirect msgDirection (DirectChat ct) + deleteItem :: DB.Connection -> CChatItem 'CTGroup -> IO ChatItemDeletion + deleteItem db (CChatItem md ci) = do + ci' <- case byGroupMember_ of + Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m deletedTs + Nothing -> Nothing <$ deleteGroupChatItem db user gInfo ci + pure $ groupDeletion md gInfo ci ci' -markGroupCIDeleted :: MsgDirectionI d => User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse -markGroupCIDeleted user gInfo ci@ChatItem {file} msgId byUser byGroupMember_ deletedTs = do - cancelCIFile user file - ci' <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ deletedTs - pure $ CRChatItemDeleted user (gItem ci) (Just $ gItem ci') byUser False +deleteLocalCIs :: User -> NoteFolder -> [CChatItem 'CTLocal] -> Bool -> Bool -> CM ChatResponse +deleteLocalCIs user nf items byUser timed = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + deleteFilesLocally ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (deleteItem db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser timed where - gItem = AChatItem SCTGroup msgDirection (GroupChat gInfo) + deleteItem db (CChatItem md ci) = do + deleteLocalChatItem db user nf ci + pure $ ChatItemDeletion (nfItem md ci) Nothing + nfItem :: MsgDirectionI d => SMsgDirection d -> ChatItem 'CTLocal d -> AChatItem + nfItem md = AChatItem SCTLocal md (LocalChat nf) -cancelCIFile :: MsgDirectionI d => User -> Maybe (CIFile d) -> CM () -cancelCIFile user file_ = - forM_ file_ $ \file -> do - let filesInfo = [mkCIFileInfo file] - cancelFilesInProgress user filesInfo +deleteCIFiles :: User -> [CIFileInfo] -> CM () +deleteCIFiles user filesInfo = do + cancelFilesInProgress user filesInfo + deleteFilesLocally filesInfo + +markDirectCIsDeleted :: User -> Contact -> [CChatItem 'CTDirect] -> Bool -> UTCTime -> CM ChatResponse +markDirectCIsDeleted user ct items byUser deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + cancelFilesInProgress user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser False + where + markDeleted db (CChatItem md ci) = do + ci' <- markDirectChatItemDeleted db user ct ci deletedTs + pure $ contactDeletion md ct ci (Just ci') + +markGroupCIsDeleted :: User -> GroupInfo -> [CChatItem 'CTGroup] -> Bool -> Maybe GroupMember -> UTCTime -> CM ChatResponse +markGroupCIsDeleted user gInfo items byUser byGroupMember_ deletedTs = do + let ciFilesInfo = mapMaybe (\(CChatItem _ ChatItem {file}) -> mkCIFileInfo <$> file) items + cancelFilesInProgress user ciFilesInfo + (errs, deletions) <- lift $ partitionEithers <$> withStoreBatch' (\db -> map (markDeleted db) items) + unless (null errs) $ toView $ CRChatErrors (Just user) errs + pure $ CRChatItemsDeleted user deletions byUser False + where + markDeleted db (CChatItem md ci) = do + ci' <- markGroupChatItemDeleted db user gInfo ci byGroupMember_ deletedTs + pure $ groupDeletion md gInfo ci (Just ci') + +groupDeletion :: MsgDirectionI d => SMsgDirection d -> GroupInfo -> ChatItem 'CTGroup d -> Maybe (ChatItem 'CTGroup d) -> ChatItemDeletion +groupDeletion md g ci ci' = ChatItemDeletion (gItem ci) (gItem <$> ci') + where + gItem = AChatItem SCTGroup md (GroupChat g) + +contactDeletion :: MsgDirectionI d => SMsgDirection d -> Contact -> ChatItem 'CTDirect d -> Maybe (ChatItem 'CTDirect d) -> ChatItemDeletion +contactDeletion md ct ci ci' = ChatItemDeletion (ctItem ci) (ctItem <$> ci') + where + ctItem = AChatItem SCTDirect md (DirectChat ct) createAgentConnectionAsync :: ConnectionModeI c => User -> CommandFunction -> Bool -> SConnectionMode c -> SubscriptionMode -> CM (CommandId, ConnId) createAgentConnectionAsync user cmdFunction enableNtfs cMode subMode = do @@ -7441,8 +7599,8 @@ chatCommandP = "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), "/_create *" *> (APICreateChatItem <$> A.decimal <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), - "/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode), - "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <* A.space <*> A.decimal <* A.space <*> A.decimal), + "/_delete item " *> (APIDeleteChatItem <$> chatRefP <*> _strP <* A.space <*> ciDeleteMode), + "/_delete member item #" *> (APIDeleteMemberChatItem <$> A.decimal <*> _strP), "/_reaction " *> (APIChatItemReaction <$> chatRefP <* A.space <*> A.decimal <* A.space <*> onOffP <* A.space <*> jsonP), "/_forward " *> (APIForwardChatItem <$> chatRefP <* A.space <*> chatRefP <* A.space <*> A.decimal <*> sendMessageTTLP), "/_read user " *> (APIUserRead <$> A.decimal), diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index c5c5ff7eed..f3de92e1f2 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} module Simplex.Chat.Bot where @@ -73,9 +74,9 @@ sendComposedMessage' cc ctId quotedItemId msgContent = do deleteMessage :: ChatController -> Contact -> ChatItemId -> IO () deleteMessage cc ct chatItemId = do - let cmd = APIDeleteChatItem (contactRef ct) chatItemId CIDMInternal + let cmd = APIDeleteChatItem (contactRef ct) [chatItemId] CIDMInternal sendChatCmd cc cmd >>= \case - CRChatItemDeleted {} -> printLog cc CLLInfo $ "deleted message from " <> contactInfo ct + CRChatItemsDeleted {} -> printLog cc CLLInfo $ "deleted message(s) from " <> contactInfo ct r -> putStrLn $ "unexpected delete message response: " <> show r contactRef :: Contact -> ChatRef diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 0c34ea2beb..59b91dc1c1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -69,7 +69,7 @@ import Simplex.Chat.Types.UITheme import Simplex.Chat.Util (liftIOEither) import Simplex.FileTransfer.Description (FileDescriptionURI) import Simplex.Messaging.Agent (AgentClient, SubscriptionsInfo) -import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, ServerQueueInfo, SMPServerSubs, UserNetworkInfo) +import Simplex.Messaging.Agent.Client (AgentLocks, AgentQueuesInfo (..), AgentWorkersDetails (..), AgentWorkersSummary (..), ProtocolTestFailure, SMPServerSubs, ServerQueueInfo, UserNetworkInfo) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig, NetworkConfig, ServerCfg) import Simplex.Messaging.Agent.Lock import Simplex.Messaging.Agent.Protocol @@ -293,8 +293,8 @@ data ChatCommand | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} | APICreateChatItem {noteFolderId :: NoteFolderId, composedMessage :: ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} - | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode - | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId + | APIDeleteChatItem ChatRef (NonEmpty ChatItemId) CIDeleteMode + | APIDeleteMemberChatItem GroupId (NonEmpty ChatItemId) | APIChatItemReaction {chatRef :: ChatRef, chatItemId :: ChatItemId, add :: Bool, reaction :: MsgReaction} | APIForwardChatItem {toChatRef :: ChatRef, fromChatRef :: ChatRef, chatItemId :: ChatItemId, ttl :: Maybe Int} | APIUserRead UserId @@ -599,7 +599,7 @@ data ChatResponse | CRChatItemUpdated {user :: User, chatItem :: AChatItem} | CRChatItemNotChanged {user :: User, chatItem :: AChatItem} | CRChatItemReaction {user :: User, added :: Bool, reaction :: ACIReaction} - | CRChatItemDeleted {user :: User, deletedChatItem :: AChatItem, toChatItem :: Maybe AChatItem, byUser :: Bool, timed :: Bool} + | CRChatItemsDeleted {user :: User, chatItemDeletions :: [ChatItemDeletion], byUser :: Bool, timed :: Bool} | CRChatItemDeletedNotFound {user :: User, contact :: Contact, sharedMsgId :: SharedMsgId} | CRBroadcastSent {user :: User, msgContent :: MsgContent, successes :: Int, failures :: Int, timestamp :: UTCTime} | CRMsgIntegrityError {user :: User, msgError :: MsgErrorType} @@ -1081,6 +1081,12 @@ tmeToPref currentTTL tme = uncurry TimedMessagesPreference $ case tme of TMEEnableKeepTTL -> (FAYes, currentTTL) TMEDisableKeepTTL -> (FANo, currentTTL) +data ChatItemDeletion = ChatItemDeletion + { deletedChatItem :: AChatItem, + toChatItem :: Maybe AChatItem + } + deriving (Show) + data ChatLogLevel = CLLDebug | CLLInfo | CLLWarning | CLLError | CLLImportant deriving (Eq, Ord, Show) @@ -1487,6 +1493,8 @@ $(JQ.deriveJSON defaultJSON ''ServerAddress) $(JQ.deriveJSON defaultJSON ''ParsedServerAddress) +$(JQ.deriveJSON defaultJSON ''ChatItemDeletion) + $(JQ.deriveJSON defaultJSON ''CoreVersionInfo) $(JQ.deriveJSON defaultJSON ''SlowSQLQuery) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index e59429b7ea..78e3b4c640 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -35,7 +35,7 @@ import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) -import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay) +import Data.Time.Clock (UTCTime, diffUTCTime, nominalDay, NominalDiffTime) import Data.Type.Equality import Data.Typeable (Typeable) import Database.SQLite.Simple.FromField (FromField (..)) @@ -364,15 +364,19 @@ data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta mkCIMeta :: forall c d. ChatTypeI c => ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe Bool -> Maybe SharedMsgId -> Maybe CIForwardedFrom -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> UTCTime -> ChatItemTs -> Maybe GroupMemberId -> UTCTime -> UTCTime -> CIMeta c d mkCIMeta itemId itemContent itemText itemStatus sentViaProxy itemSharedMsgId itemForwarded itemDeleted itemEdited itemTimed itemLive currentTs itemTs forwardedByMember createdAt updatedAt = - let deletable = case itemContent of - CISndMsgContent _ -> - case chatTypeI @c of - SCTLocal -> isNothing itemDeleted - _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted - _ -> False + let deletable = deletable' itemContent itemDeleted itemTs nominalDay currentTs editable = deletable && isNothing itemForwarded in CIMeta {itemId, itemTs, itemText, itemStatus, sentViaProxy, itemSharedMsgId, itemForwarded, itemDeleted, itemEdited, itemTimed, itemLive, deletable, editable, forwardedByMember, createdAt, updatedAt} +deletable' :: forall c d. ChatTypeI c => CIContent d -> Maybe (CIDeleted c) -> UTCTime -> NominalDiffTime -> UTCTime -> Bool +deletable' itemContent itemDeleted itemTs allowedInterval currentTs = + case itemContent of + CISndMsgContent _ -> + case chatTypeI @c of + SCTLocal -> isNothing itemDeleted + _ -> diffUTCTime currentTs itemTs < allowedInterval && isNothing itemDeleted + _ -> False + dummyMeta :: ChatItemId -> UTCTime -> Text -> CIMeta c 'MDSnd dummyMeta itemId ts itemText = CIMeta diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index d611760fbf..6d4b2eda68 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -31,8 +31,9 @@ import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as LB +import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as L -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.String import Data.Text (Text) import qualified Data.Text as T @@ -63,12 +64,14 @@ import Simplex.Messaging.Version hiding (version) -- 5 - batch sending messages (12/23/2023) -- 6 - send group welcome message after history (12/29/2023) -- 7 - update member profiles (1/15/2024) +-- 8 - compress messages and PQ e2e encryption (2024-03-08) +-- 9 - batch sending in direct connections (2024-07-24) -- This should not be used directly in code, instead use `maxVersion chatVRange` from ChatConfig. -- This indirection is needed for backward/forward compatibility testing. -- Testing with real app versions is still needed, as tests use the current code with different version ranges, not the old code. currentChatVersion :: VersionChat -currentChatVersion = VersionChat 8 +currentChatVersion = VersionChat 9 -- This should not be used directly in code, instead use `chatVRange` from ChatConfig (see comment above) supportedChatVRange :: VersionRangeChat @@ -103,6 +106,10 @@ memberProfileUpdateVersion = VersionChat 7 pqEncryptionCompressionVersion :: VersionChat pqEncryptionCompressionVersion = VersionChat 8 +-- version range that supports batch sending in direct connections, and forwarding batched messages in groups +batchSend2Version :: VersionChat +batchSend2Version = VersionChat 9 + agentToChatVersion :: VersionSMPA -> VersionChat agentToChatVersion v | v < pqdrSMPAgentVersion = initialChatVersion @@ -323,13 +330,20 @@ forwardedGroupMsg msg@ChatMessage {chatMsgEvent} = case encoding @e of SJson | isForwardedGroupMsg chatMsgEvent -> Just msg _ -> Nothing --- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat -forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> ChatMessage e -> [GroupMember] -forwardedToGroupMembers ms ChatMessage {chatMsgEvent} = case encoding @e of - SJson -> case chatMsgEvent of - XGrpMemRestrict mId _ -> filter (\GroupMember {memberId} -> memberId /= mId) ms - _ -> ms - _ -> [] +-- applied after checking forwardedGroupMsg and building list of group members to forward to, see Chat; +-- this filters out members if any of forwarded events in batch is an XGrpMemRestrict event referring to them, +-- but practically XGrpMemRestrict is not batched with other events so it wouldn't prevent forwarding of other events +-- to these members +forwardedToGroupMembers :: forall e. MsgEncodingI e => [GroupMember] -> NonEmpty (ChatMessage e) -> [GroupMember] +forwardedToGroupMembers ms forwardedMsgs = + filter (\GroupMember {memberId} -> memberId `notElem` restrictMemberIds) ms + where + restrictMemberIds = mapMaybe restrictMemberId $ L.toList forwardedMsgs + restrictMemberId ChatMessage {chatMsgEvent} = case encoding @e of + SJson -> case chatMsgEvent of + XGrpMemRestrict mId _ -> Just mId + _ -> Nothing + _ -> Nothing data MsgReaction = MREmoji {emoji :: MREmojiChar} | MRUnknown {tag :: Text, json :: J.Object} deriving (Eq, Show) diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index 5d9f5a7619..b1bd1b8dd2 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -19,7 +19,7 @@ module Simplex.Chat.Store.Messages -- * Message and chat item functions deleteContactCIs, getGroupFileInfo, - deleteGroupCIs, + deleteGroupChatItemsMessages, createNewSndMessage, createSndMsgDelivery, createNewMessageAndRcvMsgDelivery, @@ -170,8 +170,8 @@ getGroupFileInfo db User {userId} GroupInfo {groupId} = map toFileInfo <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ? AND i.group_id = ?") (userId, groupId) -deleteGroupCIs :: DB.Connection -> User -> GroupInfo -> IO () -deleteGroupCIs db User {userId} GroupInfo {groupId} = do +deleteGroupChatItemsMessages :: DB.Connection -> User -> GroupInfo -> IO () +deleteGroupChatItemsMessages db User {userId} GroupInfo {groupId} = do DB.execute db "DELETE FROM messages WHERE group_id = ?" (Only groupId) DB.execute db "DELETE FROM chat_item_reactions WHERE group_id = ?" (Only groupId) DB.execute db "DELETE FROM chat_items WHERE user_id = ? AND group_id = ?" (userId, groupId) @@ -1733,11 +1733,10 @@ deleteChatItemVersions_ :: DB.Connection -> ChatItemId -> IO () deleteChatItemVersions_ db itemId = DB.execute db "DELETE FROM chat_item_versions WHERE chat_item_id = ?" (Only itemId) -markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> MessageId -> UTCTime -> IO (ChatItem 'CTDirect d) -markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} msgId deletedTs = do +markDirectChatItemDeleted :: DB.Connection -> User -> Contact -> ChatItem 'CTDirect d -> UTCTime -> IO (ChatItem 'CTDirect d) +markDirectChatItemDeleted db User {userId} Contact {contactId} ci@ChatItem {meta} deletedTs = do currentTs <- liftIO getCurrentTime let itemId = chatItemId' ci - insertChatItemMessage_ db itemId msgId currentTs DB.execute db [sql| @@ -1900,7 +1899,7 @@ updateGroupChatItemModerated db User {userId} GroupInfo {groupId} ci m@GroupMemb WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] (deletedTs, groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) - pure $ ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing} + pure ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated (Just deletedTs) m), editable = False, deletable = False}, formattedText = Nothing} updateGroupCIBlockedByAdmin :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> UTCTime -> IO (ChatItem 'CTGroup d) updateGroupCIBlockedByAdmin db User {userId} GroupInfo {groupId} ci deletedTs = do @@ -1931,14 +1930,13 @@ pattern DBCIBlocked = 2 pattern DBCIBlockedByAdmin :: Int pattern DBCIBlockedByAdmin = 3 -markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> MessageId -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d) -markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} msgId byGroupMember_ deletedTs = do +markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> ChatItem 'CTGroup d -> Maybe GroupMember -> UTCTime -> IO (ChatItem 'CTGroup d) +markGroupChatItemDeleted db User {userId} GroupInfo {groupId} ci@ChatItem {meta} byGroupMember_ deletedTs = do currentTs <- liftIO getCurrentTime let itemId = chatItemId' ci (deletedByGroupMemberId, itemDeleted) = case byGroupMember_ of Just m@GroupMember {groupMemberId} -> (Just groupMemberId, Just $ CIModerated (Just deletedTs) m) _ -> (Nothing, Just $ CIDeleted @'CTGroup (Just deletedTs)) - insertChatItemMessage_ db itemId msgId currentTs DB.execute db [sql| diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 5c36994190..2d1039e585 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -71,7 +71,7 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do CRChatItems u chatName_ _ -> whenCurrUser cc u $ mapM_ (setActive ct . chatActiveTo) chatName_ CRNewChatItem u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo CRChatItemUpdated u (AChatItem _ SMDSnd cInfo _) -> whenCurrUser cc u $ setActiveChat ct cInfo - CRChatItemDeleted u (AChatItem _ _ cInfo _) _ _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo + CRChatItemsDeleted u ((ChatItemDeletion (AChatItem _ _ cInfo _) _) : _) _ _ -> whenCurrUser cc u $ setActiveChat ct cInfo CRContactDeleted u c -> whenCurrUser cc u $ unsetActiveContact ct c CRGroupDeletedUser u g -> whenCurrUser cc u $ unsetActiveGroup ct g CRSentGroupInvitation u g _ _ -> whenCurrUser cc u $ setActiveGroup ct g diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 2ac29be60d..545f8c08e4 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -127,7 +127,10 @@ responseToView hu@(currentRH, user_) ChatConfig {logLevel, showReactions, showRe CRChatItemStatusUpdated u ci -> ttyUser u $ viewChatItemStatusUpdated ci ts tz testView showReceipts CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted u chat item $ viewItemUpdate chat item liveItems ts tz CRChatItemNotChanged u ci -> ttyUser u $ viewItemNotChanged ci - CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView + CRChatItemsDeleted u deletions byUser timed -> case deletions of + [ChatItemDeletion (AChatItem _ _ chat deletedItem) toItem] -> + ttyUser u $ unmuted u chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts tz testView + deletions' -> ttyUser u [sShow (length deletions') <> " messages deleted"] CRChatItemReaction u added (ACIReaction _ _ chat reaction) -> ttyUser u $ unmutedReaction u chat reaction $ viewItemReaction showReactions chat reaction added ts tz CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent u mc s f t -> ttyUser u $ viewSentBroadcast mc s f ts tz t diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index ffea6a3529..e3d557166b 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -224,10 +224,11 @@ testCfgCreateGroupDirect = mkCfgCreateGroupDirect testCfg mkCfgCreateGroupDirect :: ChatConfig -> ChatConfig -mkCfgCreateGroupDirect cfg = cfg { - chatVRange = groupCreateDirectVRange, - agentConfig = testAgentCfgSlow -} +mkCfgCreateGroupDirect cfg = + cfg + { chatVRange = groupCreateDirectVRange, + agentConfig = testAgentCfgSlow + } groupCreateDirectVRange :: VersionRangeChat groupCreateDirectVRange = mkVersionRange (VersionChat 1) (VersionChat 1) diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index 1054051d4f..473d62a8cf 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -15,6 +15,7 @@ import Data.Aeson (ToJSON) import qualified Data.Aeson as J import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as LB +import Data.List (intercalate) import qualified Data.Text as T import Simplex.Chat.AppSettings (defaultAppSettings) import qualified Simplex.Chat.AppSettings as AS @@ -44,6 +45,8 @@ chatDirectTests = do it "direct message update" testDirectMessageUpdate it "direct message edit history" testDirectMessageEditHistory it "direct message delete" testDirectMessageDelete + it "direct message delete multiple" testDirectMessageDeleteMultiple + it "direct message delete multiple (many chat batches)" testDirectMessageDeleteMultipleManyBatches it "direct live message" testDirectLiveMessage it "direct timed message" testDirectTimedMessage it "repeat AUTH errors disable contact" testRepeatAuthErrorsDisableContact @@ -685,6 +688,52 @@ testDirectMessageDelete = bob #$> ("/_delete item @2 " <> itemId 4 <> " internal", id, "message deleted") bob #$> ("/_get chat @2 count=100", chat', chatFeatures' <> [((0, "hello 🙂"), Nothing), ((1, "do you receive my messages?"), Just (0, "hello 🙂"))]) +testDirectMessageDeleteMultiple :: HasCallStack => FilePath -> IO () +testDirectMessageDeleteMultiple = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + + alice #> "@bob hello" + bob <# "alice> hello" + msgId1 <- lastItemId alice + + alice #> "@bob hey" + bob <# "alice> hey" + msgId2 <- lastItemId alice + + alice ##> ("/_delete item @2 " <> msgId1 <> "," <> msgId2 <> " broadcast") + alice <## "2 messages deleted" + bob <# "alice> [marked deleted] hello" + bob <# "alice> [marked deleted] hey" + + alice #$> ("/_get chat @2 count=2", chat, [(1, "hello [marked deleted]"), (1, "hey [marked deleted]")]) + bob #$> ("/_get chat @2 count=2", chat, [(0, "hello [marked deleted]"), (0, "hey [marked deleted]")]) + +testDirectMessageDeleteMultipleManyBatches :: HasCallStack => FilePath -> IO () +testDirectMessageDeleteMultipleManyBatches = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + connectUsers alice bob + + alice #> "@bob message 0" + bob <# "alice> message 0" + msgIdFirst <- lastItemId alice + + forM_ [(1 :: Int) .. 300] $ \i -> do + alice #> ("@bob message " <> show i) + bob <# ("alice> message " <> show i) + msgIdLast <- lastItemId alice + + let mIdFirst = read msgIdFirst :: Int + mIdLast = read msgIdLast :: Int + deleteIds = intercalate "," (map show [mIdFirst .. mIdLast]) + alice `send` ("/_delete item @2 " <> deleteIds <> " broadcast") + _ <- getTermLine alice + alice <## "301 messages deleted" + forM_ [(0 :: Int) .. 300] $ \i -> do + bob <# ("alice> [marked deleted] message " <> show i) + testDirectLiveMessage :: HasCallStack => FilePath -> IO () testDirectLiveMessage = testChat2 aliceProfile bobProfile $ \alice bob -> do @@ -1138,6 +1187,7 @@ testSubscribeAppNSE tmp = alice <## "chat suspended" nseAlice ##> "/_start main=off" nseAlice <## "chat started" + threadDelay 100000 nseAlice ##> "/ad" cLink <- getContactLink nseAlice True bob ##> ("/c " <> cLink) diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index aa633d0685..07da140d78 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -11,7 +11,7 @@ import ChatClient import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) -import Control.Monad (void, when) +import Control.Monad (forM_, void, when) import qualified Data.ByteString.Char8 as B import Data.List (isInfixOf) import qualified Data.Text as T @@ -19,6 +19,7 @@ import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Options import Simplex.Chat.Protocol (supportedChatVRange) import Simplex.Chat.Store (agentStoreFile, chatStoreFile) +import Data.List (intercalate) import Simplex.Chat.Types (VersionRangeChat) import Simplex.Chat.Types.Shared (GroupMemberRole (..)) import Simplex.Messaging.Agent.Env.SQLite @@ -52,12 +53,16 @@ chatGroupTests = do it "group message update" testGroupMessageUpdate it "group message edit history" testGroupMessageEditHistory it "group message delete" testGroupMessageDelete + it "group message delete multiple" testGroupMessageDeleteMultiple + it "group message delete multiple (many chat batches)" testGroupMessageDeleteMultipleManyBatches it "group live message" testGroupLiveMessage it "update group profile" testUpdateGroupProfile it "update member role" testUpdateMemberRole it "unused contacts are deleted after all their groups are deleted" testGroupDeleteUnusedContacts it "group description is shown as the first message to new members" testGroupDescription it "moderate message of another group member" testGroupModerate + it "moderate own message (should process as deletion)" testGroupModerateOwn + it "moderate multiple messages" testGroupModerateMultiple it "moderate message of another group member (full delete)" testGroupModerateFullDelete it "moderate message that arrives after the event of moderation" testGroupDelayedModeration it "moderate message that arrives after the event of moderation (full delete)" testGroupDelayedModerationFullDelete @@ -1254,6 +1259,77 @@ testGroupMessageDelete = bob #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "how are you? [marked deleted]"), Nothing)]) cath #$> ("/_get chat #1 count=3", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!")), ((1, "how are you? [marked deleted]"), Nothing)]) +testGroupMessageDeleteMultiple :: HasCallStack => FilePath -> IO () +testGroupMessageDeleteMultiple = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + threadDelay 1000000 + alice #> "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath <# "#team alice> hello") + msgId1 <- lastItemId alice + + threadDelay 1000000 + alice #> "#team hey" + concurrently_ + (bob <# "#team alice> hey") + (cath <# "#team alice> hey") + msgId2 <- lastItemId alice + + threadDelay 1000000 + alice ##> ("/_delete item #1 " <> msgId1 <> "," <> msgId2 <> " broadcast") + alice <## "2 messages deleted" + concurrentlyN_ + [ do + bob <# "#team alice> [marked deleted] hello" + bob <# "#team alice> [marked deleted] hey", + do + cath <# "#team alice> [marked deleted] hello" + cath <# "#team alice> [marked deleted] hey" + ] + + alice #$> ("/_get chat #1 count=2", chat, [(1, "hello [marked deleted]"), (1, "hey [marked deleted]")]) + bob #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted]"), (0, "hey [marked deleted]")]) + cath #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted]"), (0, "hey [marked deleted]")]) + +testGroupMessageDeleteMultipleManyBatches :: HasCallStack => FilePath -> IO () +testGroupMessageDeleteMultipleManyBatches = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + bob ##> "/set receipts all off" + bob <## "ok" + cath ##> "/set receipts all off" + cath <## "ok" + + alice #> "#team message 0" + concurrently_ + (bob <# "#team alice> message 0") + (cath <# "#team alice> message 0") + msgIdFirst <- lastItemId alice + + forM_ [(1 :: Int) .. 300] $ \i -> do + alice #> ("#team message " <> show i) + concurrently_ + (bob <# ("#team alice> message " <> show i)) + (cath <# ("#team alice> message " <> show i)) + msgIdLast <- lastItemId alice + + let mIdFirst = read msgIdFirst :: Int + mIdLast = read msgIdLast :: Int + deleteIds = intercalate "," (map show [mIdFirst .. mIdLast]) + alice `send` ("/_delete item #1 " <> deleteIds <> " broadcast") + _ <- getTermLine alice + alice <## "301 messages deleted" + forM_ [(0 :: Int) .. 300] $ \i -> + concurrently_ + (bob <# ("#team alice> [marked deleted] message " <> show i)) + (cath <# ("#team alice> [marked deleted] message " <> show i)) + testGroupLiveMessage :: HasCallStack => FilePath -> IO () testGroupLiveMessage = testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do @@ -1539,7 +1615,7 @@ testGroupModerate = (bob <# "#team alice> hello") (cath <# "#team alice> hello") bob ##> "\\\\ #team @alice hello" - bob <## "#team: you have insufficient permissions for this action, the required role is owner" + bob <## "cannot delete this item" threadDelay 1000000 cath #> "#team hi" concurrently_ @@ -1554,6 +1630,55 @@ testGroupModerate = bob #$> ("/_get chat #1 count=1", chat, [(0, "hi [marked deleted by you]")]) cath #$> ("/_get chat #1 count=1", chat, [(1, "hi [marked deleted by bob]")]) +testGroupModerateOwn :: HasCallStack => FilePath -> IO () +testGroupModerateOwn = + testChat2 aliceProfile bobProfile $ + \alice bob -> do + createGroup2 "team" alice bob + threadDelay 1000000 + alice #> "#team hello" + bob <# "#team alice> hello" + alice ##> "\\\\ #team @alice hello" + alice <## "message marked deleted by you" + bob <# "#team alice> [marked deleted by alice] hello" + alice #$> ("/_get chat #1 count=1", chat, [(1, "hello [marked deleted by you]")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "hello [marked deleted by alice]")]) + +testGroupModerateMultiple :: HasCallStack => FilePath -> IO () +testGroupModerateMultiple = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + + threadDelay 1000000 + alice #> "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath <# "#team alice> hello") + msgId1 <- lastItemId alice + + threadDelay 1000000 + bob #> "#team hey" + concurrently_ + (alice <# "#team bob> hey") + (cath <# "#team bob> hey") + msgId2 <- lastItemId alice + + alice ##> ("/_delete member item #1 " <> msgId1 <> "," <> msgId2) + alice <## "2 messages deleted" + concurrentlyN_ + [ do + bob <# "#team alice> [marked deleted by alice] hello" + bob <# "#team bob> [marked deleted by alice] hey", + do + cath <# "#team alice> [marked deleted by alice] hello" + cath <# "#team bob> [marked deleted by alice] hey" + ] + + alice #$> ("/_get chat #1 count=2", chat, [(1, "hello [marked deleted by you]"), (0, "hey [marked deleted by you]")]) + bob #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted by alice]"), (1, "hey [marked deleted by alice]")]) + cath #$> ("/_get chat #1 count=2", chat, [(0, "hello [marked deleted by alice]"), (0, "hey [marked deleted by alice]")]) + testGroupModerateFullDelete :: HasCallStack => FilePath -> IO () testGroupModerateFullDelete = testChatCfg3 testCfgCreateGroupDirect aliceProfile bobProfile cathProfile $ diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 6971898ddf..23004677c9 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -2169,7 +2169,7 @@ testSetUITheme = a <## "you've shared main profile with this contact" a <## "connection not verified, use /code command to see security code" a <## "quantum resistant end-to-end encryption" - a <## "peer chat protocol version range: (Version 1, Version 8)" + a <## "peer chat protocol version range: (Version 1, Version 9)" groupInfo a = do a <## "group ID: 1" a <## "current members: 1" diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 0bc801e824..d9552452cd 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -133,7 +133,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) it "x.msg.new chat message with chat version range" $ - "{\"v\":\"1-8\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" + "{\"v\":\"1-9\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"}}}" ##==## ChatMessage supportedChatVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing))) it "x.msg.new quote" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello to you too\",\"type\":\"text\"},\"quote\":{\"content\":{\"text\":\"hello there!\",\"type\":\"text\"},\"msgRef\":{\"msgId\":\"BQYHCA==\",\"sent\":true,\"sentAt\":\"1970-01-01T00:00:01.000000001Z\"}}}}" @@ -243,13 +243,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} it "x.grp.mem.new with member chat version range" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-8\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.new\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-9\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemNew MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} it "x.grp.mem.intro" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} Nothing it "x.grp.mem.intro with member chat version range" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-8\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-9\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemIntro MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} Nothing it "x.grp.mem.intro with member restrictions" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.intro\",\"params\":{\"memberRestrictions\":{\"restriction\":\"blocked\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" @@ -264,7 +264,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"directConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-3%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\",\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-3%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Nothing, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Just testConnReq} it "x.grp.mem.fwd with member chat version range and w/t directConnReq" $ - "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-3%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-8\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" + "{\"v\":\"1\",\"event\":\"x.grp.mem.fwd\",\"params\":{\"memberIntro\":{\"groupConnReq\":\"simplex:/invitation#/?v=1&smp=smp%3A%2F%2F1234-w%3D%3D%40smp.simplex.im%3A5223%2F3456-w%3D%3D%23%2F%3Fv%3D1-3%26dh%3DMCowBQYDK2VuAyEAjiswwI3O_NlS8Fk3HJUW870EY2bAwmttMBsvRB9eV3o%253D&e2e=v%3D2-3%26x3dh%3DMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D%2CMEIwBQYDK2VvAzkAmKuSYeQ_m0SixPDS8Wq8VBaTS1cW-Lp0n0h4Diu-kUpR-qXx4SDJ32YGEFoGFGSbGPry5Ychr6U%3D\"},\"memberInfo\":{\"memberRole\":\"admin\",\"memberId\":\"AQIDBA==\",\"v\":\"1-9\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}}" #==# XGrpMemFwd MemberInfo {memberId = MemberId "\1\2\3\4", memberRole = GRAdmin, v = Just $ ChatVersionRange supportedChatVRange, profile = testProfile} IntroInvitation {groupConnReq = testConnReq, directConnReq = Nothing} it "x.grp.mem.info" $ "{\"v\":\"1\",\"event\":\"x.grp.mem.info\",\"params\":{\"memberId\":\"AQIDBA==\",\"profile\":{\"fullName\":\"Alice\",\"displayName\":\"alice\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII=\",\"preferences\":{\"reactions\":{\"allow\":\"yes\"},\"voice\":{\"allow\":\"yes\"}}}}}"