From 5fddf64adb51f86fe8a8fb26e0cb8970dc8b7847 Mon Sep 17 00:00:00 2001 From: spaced4ndy <8711996+spaced4ndy@users.noreply.github.com> Date: Mon, 11 Sep 2023 18:38:57 +0400 Subject: [PATCH] core: direct messages in group (#2994) --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 585 +++++++++++------- src/Simplex/Chat/Bot.hs | 2 +- src/Simplex/Chat/Controller.hs | 51 +- src/Simplex/Chat/Messages.hs | 79 ++- .../M20230904_item_direct_group_member_id.hs | 24 + src/Simplex/Chat/Migrations/chat_schema.sql | 7 +- src/Simplex/Chat/Protocol.hs | 39 +- src/Simplex/Chat/Store/Messages.hs | 154 +++-- src/Simplex/Chat/Store/Migrations.hs | 4 +- src/Simplex/Chat/Terminal/Input.hs | 18 +- src/Simplex/Chat/Terminal/Output.hs | 2 +- src/Simplex/Chat/Types.hs | 4 +- src/Simplex/Chat/View.hs | 123 ++-- tests/ChatClient.hs | 2 +- tests/ChatTests/Groups.hs | 577 ++++++++++++++++- tests/ChatTests/Utils.hs | 23 +- tests/ProtocolTests.hs | 31 +- 18 files changed, 1298 insertions(+), 428 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index ebd3d1d64..35e01e7bc 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -111,6 +111,7 @@ library Simplex.Chat.Migrations.M20230827_file_encryption Simplex.Chat.Migrations.M20230829_connections_chat_vrange Simplex.Chat.Migrations.M20230903_connections_to_subscribe + Simplex.Chat.Migrations.M20230904_item_direct_group_member_id Simplex.Chat.Mobile Simplex.Chat.Mobile.File Simplex.Chat.Mobile.Shared diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 49c5fc94e..9522d2218 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -540,8 +540,8 @@ processChatCommand = \case memStatuses -> pure $ Just $ map (uncurry MemberDeliveryStatus) memStatuses _ -> pure Nothing pure $ CRChatItemInfo user aci ChatItemInfo {itemVersions, memberDeliveryStatuses} - APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of - CTDirect -> do + APISendMessage sendRef live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case sendRef of + SRDirect chatId -> do ct@Contact {contactId, localDisplayName = c, contactUsed} <- withStore $ \db -> getContact db user chatId assertDirectAllowed user MDSnd ct XMsgNew_ unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct @@ -567,7 +567,7 @@ processChatCommand = \case (fileSize, fileMode) <- checkSndFile mc file 1 case fileMode of SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline - SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact ct + SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ SDDirect ct where smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled @@ -590,36 +590,38 @@ processChatCommand = \case pure (fileInvitation, ciFile, ft) prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> m (MsgContainer, Maybe (CIQuote 'CTDirect)) prepareMsg fInv_ timed_ = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Nothing) Just quotedItemId -> do CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getDirectChatItem db user chatId quotedItemId (origQmc, qd, sent) <- quoteData qci - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing} + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Nothing, msgScope = Nothing} qmc = quoteContent origQmc file quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) Nothing), Just quotedItem) where quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool) quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} = throwChatError CEInvalidQuote quoteData ChatItem {content = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData _ = throwChatError CEInvalidQuote - CTGroup -> do - g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId - assertUserGroupRole gInfo GRAuthor - send g + SRGroup chatId directMemberId -> do + gInfo <- withStore $ \db -> getGroupInfo db user chatId + directMember <- forM directMemberId $ \dmId -> withStore $ \db -> getGroupMember db user chatId dmId + assertGroupSendAllowed gInfo directMember + send gInfo directMember where - send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms) + send gInfo@GroupInfo {groupId, membership, localDisplayName = gName} directMember | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles | otherwise = do - (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) + ms <- getReceivingMembers user gInfo directMember + (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo ms (length ms) timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership + (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership directMember (msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) mapM_ (sendGroupFileInline ms sharedMsgId) ft_ - ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live + ci <- saveSndChatItem' user (CDGroupSnd gInfo directMember) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live withStore' $ \db -> forM_ sentToMembers $ \GroupMember {groupMemberId} -> createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew @@ -628,12 +630,12 @@ processChatCommand = \case setActive $ ActiveG gName pure $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) notAllowedError f = pure $ chatCmdError (Just user) ("feature not allowed " <> T.unpack (groupFeatureNameText f)) - setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta)) - setupSndFileTransfer g@(Group gInfo _) n = forM file_ $ \file -> do + setupSndFileTransfer :: GroupInfo -> [GroupMember] -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta)) + setupSndFileTransfer gInfo ms n = forM file_ $ \file -> do (fileSize, fileMode) <- checkSndFile mc file $ fromIntegral n case fileMode of SendFileSMP fileInline -> smpSndFileTransfer file fileSize fileInline - SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g + SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ SDGroup gInfo ms where smpSndFileTransfer :: CryptoFile -> Integer -> Maybe InlineFileMode -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) smpSndFileTransfer (CryptoFile _ (Just _)) _ _ = throwChatError $ CEFileInternal "locally encrypted files can't be sent via SMP" -- can only happen if XFTP is disabled @@ -657,25 +659,44 @@ processChatCommand = \case void . withStore' $ \db -> createSndGroupInlineFT db m conn ft sendMemberFileInline m conn ft sharedMsgId processMember _ = pure () - prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) - prepareMsg fInv_ timed_ membership = case quotedItemId_ of - Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Nothing) + prepareMsg :: Maybe FileInvitation -> Maybe CITimed -> GroupMember -> Maybe GroupMember -> m (MsgContainer, Maybe (CIQuote 'CTGroup)) + prepareMsg fInv_ timed_ membership directMember = case quotedItemId_ of + Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) (Just msgScope)), Nothing) Just quotedItemId -> do - CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + CChatItem _ qci@ChatItem {chatDir = quoteChatDir, meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getGroupChatItem db user chatId quotedItemId - (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership - let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} + let qMsgScope = directMemberToMsgScope $ ciDirDirectMember quoteChatDir + (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership qMsgScope + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId, msgScope = Just qMsgScope} qmc = quoteContent origQmc file - quotedItem = CIQuote {chatDir = qd, itemId = Just quotedItemId, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} - pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) + quotedItem = CIQuote {chatDir = qd, itemId = Just $ chatItemId' qci, sharedMsgId = itemSharedMsgId, sentAt = itemTs, content = qmc, formattedText} + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live) (Just msgScope)), Just quotedItem) where - quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) - quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ = throwChatError CEInvalidQuote - quoteData ChatItem {chatDir = CIGroupSnd, content = CISndMsgContent qmc} membership' = pure (qmc, CIQGroupSnd, True, membership') - quoteData ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m) - quoteData _ _ = throwChatError CEInvalidQuote - CTContactRequest -> pure $ chatCmdError (Just user) "not supported" - CTContactConnection -> pure $ chatCmdError (Just user) "not supported" + msgScope = directMemberToMsgScope directMember + quoteData :: ChatItem c d -> GroupMember -> MessageScope -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) + quoteData ChatItem {meta = CIMeta {itemDeleted = Just _}} _ _ = + throwChatError CEInvalidQuote + quoteData ChatItem {chatDir = qChatDir@(CIGroupSnd _), content = CISndMsgContent qmc} membership' qMsgScope = + checkDirDirectMember qChatDir $ pure (qmc, CIQGroupSnd qMsgScope, True, membership') + quoteData ChatItem {chatDir = qChatDir@(CIGroupRcv m _), content = CIRcvMsgContent qmc} _ qMsgScope = + checkDirDirectMember qChatDir $ pure (qmc, CIQGroupRcv (Just m) qMsgScope, False, m) + quoteData _ _ _ = + throwChatError CEInvalidQuote + -- can quote: + -- - group message to group (Nothing, Nothing) + -- - group message to direct member (Nothing, Just) + -- - direct message to the same direct member (Just, Just, same Id) + -- can't quote: + -- - direct message to group (Just, Nothing) + -- - direct message to another direct member (Just, Just, different Id) + checkDirDirectMember :: CIDirection 'CTGroup d -> m a -> m a + checkDirDirectMember quoteChatDir a = case (ciDirDirectMember quoteChatDir, directMember) of + (Nothing, Nothing) -> a + (Nothing, Just _) -> a + (Just _, Nothing) -> throwChatError CEInvalidQuote + (Just GroupMember {groupMemberId = dirDirectMemId}, Just GroupMember {groupMemberId = directMemId}) + | directMemId == dirDirectMemId -> a + | otherwise -> throwChatError CEInvalidQuote where quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent quoteContent qmc ciFile_ @@ -700,8 +721,8 @@ processChatCommand = \case qText = msgContentText qmc qFileName = maybe qText (T.pack . (fileName :: CIFile d -> String)) ciFile_ qTextOrFile = if T.null qText then qFileName else qText - xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) - xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do + xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> SendDirection -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) + xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n sendDirection = do let fileName = takeFileName filePath fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} fInv = xftpFileInvitation fileName fileSize fileDescr @@ -710,19 +731,20 @@ processChatCommand = \case aFileId <- withAgent $ \a -> xftpSendFile a (aUserId user) srcFile (roundedFDCount n) -- TODO CRSndFileStart event for XFTP chSize <- asks $ fileChunkSize . config + let contactOrGroup = sendDirToContactOrGroup sendDirection ft@FileTransferMeta {fileId} <- withStore' $ \db -> createSndFileTransferXFTP db user contactOrGroup file fInv (AgentSndFileId aFileId) chSize let fileSource = Just $ CryptoFile filePath cfArgs ciFile = CIFile {fileId, fileName, fileSize, fileSource, fileStatus = CIFSSndStored, fileProtocol = FPXFTP} - case contactOrGroup of - CGContact Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr - CGGroup (Group _ ms) -> forM_ ms $ \m -> saveMemberFD m `catchChatError` (toView . CRChatError (Just user)) - where - -- we are not sending files to pending members, same as with inline files - saveMemberFD m@GroupMember {activeConn = Just conn@Connection {connStatus}} = - when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ - withStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr - saveMemberFD _ = pure () + case sendDirection of + SDDirect Contact {activeConn} -> withStore' $ \db -> createSndFTDescrXFTP db user Nothing activeConn ft fileDescr + SDGroup _ ms -> forM_ ms $ \m -> saveMemberFD ft fileDescr m `catchChatError` (toView . CRChatError (Just user)) pure (fInv, ciFile, ft) + where + -- we are not sending files to pending members, same as with inline files + saveMemberFD ft fileDescr m@GroupMember {activeConn = Just conn@Connection {connStatus}} = + when ((connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn)) $ + withStore' $ \db -> createSndFTDescrXFTP db user (Just m) conn ft fileDescr + saveMemberFD _ _ _ = pure () unzipMaybe3 :: Maybe (a, b, c) -> (Maybe a, Maybe b, Maybe c) unzipMaybe3 (Just (a, b, c)) = (Just a, Just b, Just c) unzipMaybe3 _ = (Nothing, Nothing, Nothing) @@ -750,28 +772,28 @@ processChatCommand = \case _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> do - Group gInfo@GroupInfo {groupId, localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId - assertUserGroupRole gInfo GRAuthor - cci <- withStore $ \db -> getGroupChatItem db user chatId itemId - case cci of - CChatItem SMDSnd ci@ChatItem {meta = CIMeta {itemSharedMsgId, itemTimed, itemLive, editable}, content = ciContent} -> do - case (ciContent, itemSharedMsgId, editable) of - (CISndMsgContent oldMC, Just itemSharedMId, True) -> do - let changed = mc /= oldMC - if changed || fromMaybe False itemLive - then do - (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms (XMsgUpdate itemSharedMId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive)) - ci' <- withStore' $ \db -> do - currentTs <- liftIO getCurrentTime - when changed $ - addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) - updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId - startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' - setActive $ ActiveG gName - pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci') - else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) - _ -> throwChatError CEInvalidChatItemUpdate - CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate + aci <- withStore $ \db -> getAChatItem db user (ChatRef CTGroup chatId) itemId + case aci of + AChatItem _ _ (GroupChat gInfo) ci@ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, editable = True}, content = CISndMsgContent oldMC} -> do + let GroupInfo {groupId, localDisplayName = gName} = gInfo + ChatItem {meta = CIMeta {itemTimed, itemLive}} = ci + changed = mc /= oldMC + if changed || fromMaybe False itemLive + then do + (ms, directMember') <- getReceivingMembers' user gInfo directMember + assertGroupSendAllowed gInfo directMember' + let msg = XMsgUpdate sharedMsgId mc (ttl' <$> itemTimed) (justTrue . (live &&) =<< itemLive) + (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms msg + ci' <- withStore' $ \db -> do + currentTs <- liftIO getCurrentTime + when changed $ + addInitialAndNewCIVersions db itemId (chatItemTs' ci, oldMC) (currentTs, mc) + updateGroupChatItem db user groupId ci (CISndMsgContent mc) live $ Just msgId + startUpdatedTimedItemThread user (ChatRef CTGroup groupId) ci ci' + setActive $ ActiveG gName + pure $ CRChatItemUpdated user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci') + else pure $ CRChatItemNotChanged user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) + _ -> throwChatError CEInvalidChatItemUpdate CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteChatItem (ChatRef cType chatId) itemId mode -> withUser $ \user -> withChatLock "deleteChatItem" $ case cType of @@ -788,22 +810,25 @@ processChatCommand = \case else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete CTGroup -> do - Group gInfo ms <- withStore $ \db -> getGroup db user chatId - ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId, editable}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId - case (mode, msgDir, itemSharedMsgId, editable) of - (CIDMInternal, _, _, _) -> deleteGroupCI user gInfo ci True False Nothing =<< liftIO getCurrentTime - (CIDMBroadcast, SMDSnd, Just itemSharedMId, True) -> do - 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 + aci <- withStore $ \db -> getAChatItem db user (ChatRef CTGroup chatId) itemId + case (mode, aci) of + (CIDMInternal, AChatItem _ md (GroupChat gInfo) ci) -> do + let cci = CChatItem md ci + deleteGroupCI user gInfo cci True False Nothing =<< liftIO getCurrentTime + (CIDMBroadcast, AChatItem _ _ (GroupChat gInfo) ci@ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, editable = True}}) -> do + assertUserMembershipStatus gInfo -- can delete messages sent earlier in any role + (ms, _) <- getReceivingMembers' user gInfo directMember + (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel sharedMsgId Nothing + let cci = CChatItem SMDSnd ci + delGroupChatItem user gInfo cci msgId Nothing + _ -> throwChatError CEInvalidChatItemDelete CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactConnection -> pure $ chatCmdError (Just user) "not supported" APIDeleteMemberChatItem gId mId itemId -> withUser $ \user -> withChatLock "deleteChatItem" $ do Group gInfo@GroupInfo {membership} ms <- withStore $ \db -> getGroup db user gId ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId case (chatDir, itemSharedMsgId) of - (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do + (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId} MSGroup, Just itemSharedMId) -> do when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete assertUserGroupRole gInfo $ max GRAdmin memberRole (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId @@ -829,13 +854,15 @@ processChatCommand = \case pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTGroup -> - withStore (\db -> (,) <$> getGroup db user chatId <*> getGroupChatItem db user chatId itemId) >>= \case - (Group g@GroupInfo {membership} ms, CChatItem md ci@ChatItem {meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do + withStore (\db -> getAChatItem db user (ChatRef CTGroup chatId) itemId) >>= \case + (AChatItem _ md (GroupChat g@GroupInfo {membership}) ci@ChatItem {chatDir, meta = CIMeta {itemSharedMsgId = Just itemSharedMId}}) -> do unless (groupFeatureAllowed SGFReactions g) $ throwChatError $ CECommandError $ "feature not allowed " <> T.unpack (chatFeatureNameText CFReactions) unless (ciReactionAllowed ci) $ throwChatError $ CECommandError "reaction not allowed - chat item has no content" let GroupMember {memberId = itemMemberId} = chatItemMember g ci + directMember = ciDirDirectMember chatDir + (ms, _) <- getReceivingMembers' user g directMember rs <- withStore' $ \db -> getGroupReactions db g membership itemMemberId itemSharedMId True checkReactionAllowed rs (SndMessage {msgId}, _) <- sendGroupMessage user g ms (XMsgReact itemSharedMId (Just itemMemberId) reaction add) @@ -844,7 +871,7 @@ processChatCommand = \case setGroupReaction db g membership itemMemberId itemSharedMId True reaction add msgId createdAt liftIO $ getGroupCIReactions db g itemMemberId itemSharedMId let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction + r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction (CIGroupSnd directMember) ci' createdAt reaction pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" @@ -1208,7 +1235,7 @@ processChatCommand = \case case memberConnId m of Just connId -> do cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force - createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing + createInternalChatItem user (CDGroupSnd g Nothing) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing pure $ CRGroupMemberRatchetSyncStarted user g m cStats _ -> throwChatError CEGroupMemberNotActive APIGetContactCode contactId -> withUser $ \user -> do @@ -1368,8 +1395,8 @@ processChatCommand = \case RejectContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId - SendMessage chatName msg -> sendTextMessage chatName msg False - SendLiveMessage chatName msg -> sendTextMessage chatName msg True + SendMessage sendName msg -> sendTextMessage sendName msg False + SendLiveMessage sendName msg -> sendTextMessage sendName msg True SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withStore' (`getUserContacts` user) let cts = filter (\ct -> isReady ct && directOrUsed ct) contacts @@ -1389,7 +1416,7 @@ processChatCommand = \case contactId <- withStore $ \db -> getContactIdByName db user cName quotedItemId <- withStore $ \db -> getDirectChatItemIdByText db userId contactId msgDir quotedMsg let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand . APISendMessage (SRDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -1403,10 +1430,10 @@ processChatCommand = \case editedItemId <- getSentChatItemIdByText user chatRef editedMsg let mc = MCText msg processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc - UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do - chatRef <- getChatRef user chatName + UpdateLiveMessage sendName chatItemId live msg -> withUser $ \user -> do + sendRef <- getSendRef user sendName let mc = MCText msg - processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc + processChatCommand $ APIUpdateChatItem (sendToChatRef sendRef) chatItemId live mc ReactToMessage add reaction chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName chatItemId <- getChatItemIdByText user chatRef msg @@ -1491,7 +1518,7 @@ processChatCommand = \case _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName _ -> do (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent gEvent) + ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent gEvent) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) pure CRMemberRoleUser {user, groupInfo = gInfo, member = m {memberRole = memRole}, fromRole = mRole, toRole = memRole} APIRemoveMember groupId memberId -> withUser $ \user -> do @@ -1507,7 +1534,7 @@ processChatCommand = \case withStore' $ \db -> deleteGroupMember db user m _ -> do (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemDel mId - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) + ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) deleteMemberConnection user m -- undeleted "member connected" chat item will prevent deletion of member record @@ -1517,7 +1544,7 @@ processChatCommand = \case Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user groupId withChatLock "leaveGroup" . procCmd $ do (msg, _) <- sendGroupMessage user gInfo members XGrpLeave - ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) + ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent SGEUserLeft) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) -- TODO delete direct connections that were unused deleteGroupLinkIfExists user gInfo @@ -1600,11 +1627,13 @@ processChatCommand = \case ShowGroupLink gName -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIGetGroupLink groupId - SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do + SendGroupMessageQuote gName cName directMemberName quotedMsg msg -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName + directMemberId <- forM directMemberName $ \dmn -> withStore $ \db -> getGroupMemberIdByName db user groupId dmn quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName quotedMsg - let mc = MCText msg - processChatCommand . APISendMessage (ChatRef CTGroup groupId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + let sendRef = SRGroup groupId directMemberId + mc = MCText msg + processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc LastChats count_ -> withUser' $ \user -> do chats <- withStore' $ \db -> getChatPreviews db user False pure $ CRChats $ maybe id take count_ chats @@ -1637,19 +1666,19 @@ processChatCommand = \case processChatCommand $ APIGetChatItemInfo chatRef itemId ShowLiveItems on -> withUser $ \_ -> asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ - SendFile chatName f -> withUser $ \user -> do - chatRef <- getChatRef user chatName - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "") - SendImage chatName f -> withUser $ \user -> do - chatRef <- getChatRef user chatName + SendFile sendName f -> withUser $ \user -> do + sendRef <- getSendRef user sendName + processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCFile "") + SendImage sendName f -> withUser $ \user -> do + sendRef <- getSendRef user sendName filePath <- toFSFilePath f unless (any (`isSuffixOf` map toLower f) imageExtensions) $ throwChatError CEFileImageType {filePath} fileSize <- getFileSize filePath unless (fileSize <= maxImageSize) $ throwChatError CEFileImageSize {filePath} -- TODO include file description for preview - processChatCommand . APISendMessage chatRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview) - ForwardFile chatName fileId -> forwardFile chatName fileId SendFile - ForwardImage chatName fileId -> forwardFile chatName fileId SendImage + processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage (Just $ CF.plain f) Nothing (MCImage "" fixedImagePreview) + ForwardFile sendName fileId -> forwardFile sendName fileId SendFile + ForwardImage sendName fileId -> forwardFile sendName fileId SendImage SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ -> withChatLock "receiveFile" . procCmd $ do @@ -1673,7 +1702,7 @@ processChatCommand = \case (_, RcvFileTransfer {xftpRcvFile = f}) <- withStore (`getRcvFileTransferById` fileId) unless (isJust f) $ throwChatError $ CEFileInternal "locally encrypted files can't be received via SMP" liftIO $ Just <$> CF.randomArgs - CancelFile fileId -> withUser $ \user@User {userId} -> + CancelFile fileId -> withUser $ \user -> withChatLock "cancelFile" . procCmd $ withStore (\db -> getFileTransfer db user fileId) >>= \case FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts @@ -1683,20 +1712,22 @@ processChatCommand = \case | otherwise -> do fileAgentConnIds <- cancelSndFile user ftm fts True deleteAgentConnectionsAsync user fileAgentConnIds - sharedMsgId <- withStore $ \db -> getSharedMsgIdByFileId db userId fileId - withStore (\db -> getChatRefByFileId db user fileId) >>= \case - ChatRef CTDirect contactId -> do - contact <- withStore $ \db -> getContact db user contactId - void . sendDirectContactMessage contact $ XFileCancel sharedMsgId - ChatRef CTGroup groupId -> do - Group gInfo ms <- withStore $ \db -> getGroup db user groupId - void . sendGroupMessage user gInfo ms $ XFileCancel sharedMsgId - _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" - ci <- withStore $ \db -> getChatItemByFileId db user fileId - pure $ CRSndFileCancelled user ci ftm fts + sendXFileCancel + ci' <- withStore $ \db -> getChatItemByFileId db user fileId + pure $ CRSndFileCancelled user ci' ftm fts where fileCancelledOrCompleteSMP SndFileTransfer {fileStatus = s} = s == FSCancelled || (s == FSComplete && isNothing xftpSndFile) + sendXFileCancel :: m () + sendXFileCancel = do + ci <- withStore $ \db -> getChatItemByFileId db user fileId + case ci of + (AChatItem _ _ (DirectChat ct) ChatItem {chatDir = CIDirectSnd, meta = CIMeta {itemSharedMsgId = Just sharedMsgId}}) -> + void $ sendDirectContactMessage ct (XFileCancel sharedMsgId) + (AChatItem _ _ (GroupChat gInfo) ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId}}) -> do + (ms, _) <- getReceivingMembers' user gInfo directMember + void $ sendGroupMessage user gInfo ms (XFileCancel sharedMsgId) + _ -> throwChatError $ CEFileInternal "invalid chat ref for file transfer" FTRcv ftr@RcvFileTransfer {cancelled, fileStatus, xftpRcvFile} | cancelled -> throwChatError $ CEFileCancel fileId "file already cancelled" | rcvFileComplete fileStatus -> throwChatError $ CEFileCancel fileId "file transfer is complete" @@ -1811,6 +1842,15 @@ processChatCommand = \case CTDirect -> withStore $ \db -> getContactIdByName db user name CTGroup -> withStore $ \db -> getGroupIdByName db user name _ -> throwChatError $ CECommandError "not supported" + getSendRef :: User -> SendName -> m SendRef + getSendRef user sendName = case sendName of + SNDirect name -> SRDirect <$> withStore (\db -> getContactIdByName db user name) + SNGroup name directMemberName -> do + (gId, dmId) <- withStore $ \db -> do + gId <- getGroupIdByName db user name + dmId <- forM directMemberName $ \dmn -> getGroupMemberIdByName db user gId dmn + pure (gId, dmId) + pure $ SRGroup gId dmId checkChatStopped :: m ChatResponse -> m ChatResponse checkChatStopped a = asks agentAsync >>= readTVarIO >>= maybe a (const $ throwChatError CEChatNotStopped) setStoreChanged :: m () @@ -1943,15 +1983,29 @@ processChatCommand = \case assertUserGroupRole g GROwner g' <- withStore $ \db -> updateGroupProfile db user g p' (msg, _) <- sendGroupMessage user g' ms (XGrpInfo p') - let cd = CDGroupSnd g' + let cd = CDGroupSnd g' Nothing unless (sameGroupProfileInfo p p') $ do ci <- saveSndChatItem user cd msg (CISndGroupEvent $ SGEGroupUpdated p') toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat g') ci) createGroupFeatureChangedItems user cd CISndGroupFeature g g' pure $ CRGroupUpdated user g g' Nothing + assertGroupSendAllowed :: GroupInfo -> Maybe GroupMember -> m () + assertGroupSendAllowed + gInfo@GroupInfo {membership = GroupMember {memberRole = userRole}} + (Just GroupMember {memberRole = directMemberRole, activeConn = Just Connection {peerChatVRange}}) = do + unless (isCompatibleRange peerChatVRange groupPrivateMessagesVRange) $ throwChatError CEPeerChatVRangeIncompatible + if + | userRole >= GRAdmin || directMemberRole >= GRAdmin -> assertUserMembershipStatus gInfo + | not (groupFeatureAllowed SGFDirectMessages gInfo) -> throwChatError $ CECommandError "direct messages not allowed" + | otherwise -> assertUserGroupRole gInfo GRAuthor + assertGroupSendAllowed _ (Just GroupMember {activeConn = Nothing}) = throwChatError CEGroupMemberNotActive + assertGroupSendAllowed gInfo Nothing = assertUserGroupRole gInfo GRAuthor assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole g@GroupInfo {membership} requiredRole = do when (memberRole (membership :: GroupMember) < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole + assertUserMembershipStatus g + assertUserMembershipStatus :: GroupInfo -> m () + assertUserMembershipStatus g@GroupInfo {membership} = do when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved unless (memberActive membership) $ throwChatError CEGroupMemberNotActive @@ -1996,14 +2050,14 @@ processChatCommand = \case withServerProtocol p action = case userProtocol p of Just Dict -> action _ -> throwChatError $ CEServerProtocol $ AProtocolType p - forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse - forwardFile chatName fileId sendCommand = withUser $ \user -> do + forwardFile :: SendName -> FileTransferId -> (SendName -> FilePath -> ChatCommand) -> m ChatResponse + forwardFile sendName fileId sendCommand = withUser $ \user -> do withStore (\db -> getFileTransfer db user fileId) >>= \case FTRcv RcvFileTransfer {fileStatus = RFSComplete RcvFileInfo {filePath}} -> forward filePath FTSnd {fileTransferMeta = FileTransferMeta {filePath}} -> forward filePath _ -> throwChatError CEFileNotReceived {fileId} where - forward = processChatCommand . sendCommand chatName + forward = processChatCommand . sendCommand sendName getGroupAndMemberId :: User -> GroupName -> ContactName -> m (GroupId, GroupMemberId) getGroupAndMemberId user gName groupMemberName = withStore $ \db -> do @@ -2019,10 +2073,10 @@ processChatCommand = \case ci <- saveSndChatItem user (CDDirectSnd ct) msg content toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) setActive $ ActiveG localDisplayName - sendTextMessage chatName msg live = withUser $ \user -> do - chatRef <- getChatRef user chatName + sendTextMessage sendName msg live = withUser $ \user -> do + sendRef <- getSendRef user sendName let mc = MCText msg - processChatCommand . APISendMessage chatRef live Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand . APISendMessage sendRef live Nothing $ ComposedMessage Nothing Nothing mc sndContactCITimed :: Bool -> Contact -> Maybe Int -> m (Maybe CITimed) sndContactCITimed live = sndCITimed_ live . contactTimedTTL sndGroupCITimed :: Bool -> GroupInfo -> Maybe Int -> m (Maybe CITimed) @@ -2094,6 +2148,26 @@ processChatCommand = \case _ -> throwChatError $ CECommandError "not supported" processChatCommand $ APISetChatSettings (ChatRef cType chatId) $ updateSettings chatSettings +getReceivingMembers :: ChatMonad m => User -> GroupInfo -> Maybe GroupMember -> m [GroupMember] +getReceivingMembers user gInfo directMember = do + ms <- case directMember of + Nothing -> withStore' $ \db -> getGroupMembers db user gInfo + Just dm -> pure [dm] + pure $ filter memberCurrent ms + +-- use in contexts where directMember is retrieved via chat item direction: +-- when reading chat item member is loaded w/t connection +getReceivingMembers' :: ChatMonad m => User -> GroupInfo -> Maybe GroupMember -> m ([GroupMember], Maybe GroupMember) +getReceivingMembers' user gInfo@GroupInfo {groupId} directMember = do + (ms, dm) <- case directMember of + Nothing -> do + ms <- withStore' $ \db -> getGroupMembers db user gInfo + pure (ms, Nothing) + Just GroupMember {groupMemberId} -> do + dm <- withStore $ \db -> getGroupMember db user groupId groupMemberId + pure ([dm], Just dm) + pure (filter memberCurrent ms, dm) + assertDirectAllowed :: ChatMonad m => User -> MsgDirection -> Contact -> CMEventTag e -> m () assertDirectAllowed user dir ct event = unless (allowedChatEvent || anyDirectOrUsed ct) . unlessM directMessagesAllowed $ @@ -2312,7 +2386,7 @@ acceptFileReceive user@User {userId} RcvFileTransfer {fileId, xftpRcvFile, fileI ) receiveViaCompleteFD :: ChatMonad m => User -> FileTransferId -> RcvFileDescr -> Maybe CryptoFileArgs -> m () -receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs = +receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs = do when fileDescrComplete $ do rd <- parseFileDescription fileDescrText aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs @@ -2749,45 +2823,46 @@ processAgentMsgSndFile _corrId aFileId msg = toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal SFDONE sndDescr rfds -> do withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) - ci@(AChatItem _ d cInfo _ci@ChatItem {meta = CIMeta {itemSharedMsgId = msgId_, itemDeleted}}) <- - withStore $ \db -> getChatItemByFileId db user fileId - case (msgId_, itemDeleted) of - (Just sharedMsgId, Nothing) -> do + ci <- withStore $ \db -> getChatItemByFileId db user fileId + case (rfds, sfts, ci) of + (rfd : extraRFDs, [sft], AChatItem _ _ (DirectChat ct) ChatItem {chatDir = CIDirectSnd, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, itemDeleted = Nothing}}) -> do + checkStart ci + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct + withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId + withAgent (`xftpDeleteSndFileInternal` aFileId) + (_, _, AChatItem _ _ (GroupChat gInfo) ChatItem {chatDir = CIGroupSnd directMember, meta = CIMeta {itemSharedMsgId = Just sharedMsgId, itemDeleted = Nothing}}) -> do + checkStart ci + (ms, _) <- getReceivingMembers' user gInfo directMember + let rfdsMemberFTs = zip rfds $ memberFTs ms + extraRFDs = drop (length rfdsMemberFTs) rfds + withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) + forM_ rfdsMemberFTs $ \mt -> sendToMember gInfo mt `catchChatError` (toView . CRChatError (Just user)) + ci' <- withStore $ \db -> do + liftIO $ updateCIFileStatus db user fileId CIFSSndComplete + getChatItemByFileId db user fileId + withAgent (`xftpDeleteSndFileInternal` aFileId) + toView $ CRSndFileCompleteXFTP user ci' ft + where + memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] + memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') + where + mConns' = mapMaybe useMember ms + sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts + useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} + | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) = Just (groupMemberId, conn) + | otherwise = Nothing + useMember _ = Nothing + sendToMember :: GroupInfo -> (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m () + sendToMember GroupInfo {groupId} (rfd, (conn, sft)) = + void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId + _ -> throwChatError $ CEInternalError "invalid XFTP file transfer" + where + checkStart :: AChatItem -> m () + checkStart ci = do when (length rfds < length sfts) $ throwChatError $ CEInternalError "not enough XFTP file descriptions to send" -- TODO either update database status or move to SFPROG toView $ CRSndFileProgressXFTP user ci ft 1 1 - case (rfds, sfts, d, cInfo) of - (rfd : extraRFDs, sft : _, SMDSnd, DirectChat ct) -> do - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - msgDeliveryId <- sendFileDescription sft rfd sharedMsgId $ sendDirectContactMessage ct - withStore' $ \db -> updateSndFTDeliveryXFTP db sft msgDeliveryId - withAgent (`xftpDeleteSndFileInternal` aFileId) - (_, _, SMDSnd, GroupChat g@GroupInfo {groupId}) -> do - ms <- withStore' $ \db -> getGroupMembers db user g - let rfdsMemberFTs = zip rfds $ memberFTs ms - extraRFDs = drop (length rfdsMemberFTs) rfds - withStore' $ \db -> createExtraSndFTDescrs db user fileId (map fileDescrText extraRFDs) - forM_ rfdsMemberFTs $ \mt -> sendToMember mt `catchChatError` (toView . CRChatError (Just user)) - ci' <- withStore $ \db -> do - liftIO $ updateCIFileStatus db user fileId CIFSSndComplete - getChatItemByFileId db user fileId - withAgent (`xftpDeleteSndFileInternal` aFileId) - toView $ CRSndFileCompleteXFTP user ci' ft - where - memberFTs :: [GroupMember] -> [(Connection, SndFileTransfer)] - memberFTs ms = M.elems $ M.intersectionWith (,) (M.fromList mConns') (M.fromList sfts') - where - mConns' = mapMaybe useMember ms - sfts' = mapMaybe (\sft@SndFileTransfer {groupMemberId} -> (,sft) <$> groupMemberId) sfts - useMember GroupMember {groupMemberId, activeConn = Just conn@Connection {connStatus}} - | (connStatus == ConnReady || connStatus == ConnSndReady) && not (connDisabled conn) = Just (groupMemberId, conn) - | otherwise = Nothing - useMember _ = Nothing - sendToMember :: (ValidFileDescription 'FRecipient, (Connection, SndFileTransfer)) -> m () - sendToMember (rfd, (conn, sft)) = - void $ sendFileDescription sft rfd sharedMsgId $ \msg' -> sendDirectMessage conn msg' $ GroupId groupId - _ -> pure () - _ -> pure () -- TODO error? SFERR e | temporaryAgentError e -> throwChatError $ CEXFTPSndFile fileId (AgentSndFileId aFileId) e @@ -3123,7 +3198,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do groupInv = GroupInvitation (MemberIdRole userMemberId userRole) (MemberIdRole memberId memRole) cReq groupProfile groupLinkId (_msg, _) <- sendDirectContactMessage ct $ XGrpInv groupInv -- we could link chat item with sent group invitation message (_msg) - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing + createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing _ -> throwChatError $ CECommandError "unexpected cmdFunction" CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" CONF confId _ connInfo -> do @@ -3212,10 +3287,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let m' = m {activeConn = Just conn'} :: GroupMember updateChatLock "groupMessage" event case event of - XMsgNew mc -> canSend m' $ newGroupContentMessage gInfo m' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> canSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta + XMsgNew mc -> newGroupContentMessage gInfo m' mc msg msgMeta + XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta XMsgFileCancel sharedMsgId -> cancelGroupMessageFile gInfo m' sharedMsgId msgMeta - XMsgUpdate sharedMsgId mContent ttl live -> canSend m' $ groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live + XMsgUpdate sharedMsgId mContent ttl live -> groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m' sharedMsgId memberId msg msgMeta XMsgReact sharedMsgId (Just memberId) reaction add -> groupMsgReaction gInfo m' sharedMsgId memberId reaction add msg msgMeta -- TODO discontinue XFile @@ -3239,10 +3314,6 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do fromMaybe (sendRcptsSmallGroups user) sendRcpts && hasDeliveryReceipt (toCMEventTag event) && currentMemCount <= smallGroupsRcptsMemLimit - where - canSend mem a - | memberRole (mem :: GroupMember) <= GRObserver = messageError "member is not allowed to send messages" - | otherwise = a RCVD msgMeta msgRcpt -> withAckMessage' agentConnId conn msgMeta $ groupMsgReceived gInfo m conn msgMeta msgRcpt @@ -3253,8 +3324,8 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do SWITCH qd phase cStats -> do toView $ CRGroupMemberSwitch user gInfo m (SwitchProgress qd phase cStats) when (phase `elem` [SPStarted, SPCompleted]) $ case qd of - QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing - QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing + QDRcv -> createInternalChatItem user (CDGroupSnd gInfo Nothing) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing + QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing RSYNC rss cryptoErr_ cStats -> case (rss, connectionCode, cryptoErr_) of (RSRequired, _, Just cryptoErr) -> processErr cryptoErr @@ -3264,7 +3335,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let m' = m {activeConn = Just (conn {connectionCode = Nothing} :: Connection)} :: GroupMember ratchetSyncEventItem m' toView $ CRGroupMemberVerificationReset user gInfo m' - createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing + createInternalChatItem user (CDGroupRcv gInfo m' MSGroup) (CIRcvConnEvent RCEVerificationCodeReset) Nothing _ -> ratchetSyncEventItem m where processErr cryptoErr = do @@ -3278,10 +3349,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do Just ci -> toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) _ -> do toView $ CRGroupMemberRatchetSync user gInfo m (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing + createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvDecryptionError mde n) Nothing ratchetSyncEventItem m' = do toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing + createInternalChatItem user (CDGroupRcv gInfo m' MSGroup) (CIRcvConnEvent $ RCERatchetSync rss) Nothing OK -> -- [async agent commands] continuation on receiving OK withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} -> @@ -3578,11 +3649,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do memberConnectedChatItem :: GroupInfo -> GroupMember -> m () memberConnectedChatItem gInfo m = -- ts should be broker ts but we don't have it for CON - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing + createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvGroupEvent RGEMemberConnected) Nothing groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> m () groupDescriptionChatItem gInfo m descr = - createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing + createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvMsgContent $ MCText descr) Nothing notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do @@ -3620,7 +3691,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do newContentMessage ct@Contact {localDisplayName = c, contactUsed} mc msg@RcvMessage {sharedMsgId_} msgMeta = do unless contactUsed $ withStore' $ \db -> updateContactUsed db user ct checkIntegrityCreateItem (CDDirectRcv ct) msgMeta - let ExtMsgContent content fInv_ _ _ = mcExtMsgContent mc + let ExtMsgContent content fInv_ _ _ _ = mcExtMsgContent mc -- Uncomment to test stuck delivery on errors - see test testDirectMessageDelete -- case content of -- MCText "hello 111" -> @@ -3632,7 +3703,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do void $ newChatItem (CIRcvChatFeatureRejected CFVoice) Nothing Nothing False setActive $ ActiveC c else do - let ExtMsgContent _ _ itemTTL live_ = mcExtMsgContent mc + let ExtMsgContent _ _ itemTTL live_ _ = mcExtMsgContent mc timed_ = rcvContactCITimed ct itemTTL live = fromMaybe False live_ file_ <- processFileInvitation fInv_ content $ \db -> createRcvFileTransfer db userId ct @@ -3660,9 +3731,16 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processFDMessage fileId fileDescr groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> MsgMeta -> m () - groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr _msgMeta = do - fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId - processFDMessage fileId fileDescr + groupMessageFileDescription gInfo@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId fileDescr _msgMeta = do + cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId + case cci of + CChatItem SMDRcv ChatItem {chatDir = CIGroupRcv m' msgScope, file = Just CIFile {fileId}} -> + if sameMemberId memberId m' + then do + assertMemberSendAllowed gInfo m' msgScope directMsgProhibitedErr + processFDMessage fileId fileDescr + else messageError "x.msg.file.descr: message of another member" + _ -> messageError "x.msg.file.descr: group member attempted invalid file send" processFDMessage :: FileTransferId -> FileDescr -> m () processFDMessage fileId fileDescr = do @@ -3783,13 +3861,14 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do where updateChatItemReaction = do cr_ <- withStore $ \db -> do - CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId - if ciReactionAllowed ci + CChatItem md ci@ChatItem {chatDir} <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId + if directMemberCIUpdateAllowed ci m && ciReactionAllowed ci then liftIO $ do setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs reactions <- getGroupCIReactions db g itemMemberId sharedMsgId let ci' = CChatItem md ci {reactions} - r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction + msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir + r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m msgScope) ci' brokerTs reaction pure $ Just $ CRChatItemReaction user add r else pure Nothing mapM_ toView cr_ @@ -3797,6 +3876,12 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do reactionAllowed :: Bool -> MsgReaction -> [MsgReaction] -> Bool reactionAllowed add reaction rs = (reaction `elem` rs) /= add && not (add && length rs >= maxMsgReactions) + directMemberCIUpdateAllowed :: ChatItem 'CTGroup d -> GroupMember -> Bool + directMemberCIUpdateAllowed ChatItem {chatDir} GroupMember {groupMemberId} = + case ciDirDirectMember chatDir of + Just GroupMember {groupMemberId = directMemberId} -> groupMemberId == directMemberId + Nothing -> True + catchCINotFound :: m a -> (SharedMsgId -> m a) -> m a catchCINotFound f handle = f `catchChatError` \case @@ -3804,32 +3889,41 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do e -> throwError e newGroupContentMessage :: GroupInfo -> GroupMember -> MsgContainer -> RcvMessage -> MsgMeta -> m () - newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta - | isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice - | not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles - | otherwise = do - -- TODO integrity message check - -- check if message moderation event was received ahead of message - let timed_ = rcvGroupCITimed gInfo itemTTL - live = fromMaybe False live_ - withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case - Just ciModeration -> do - applyModeration timed_ live ciModeration - withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ - Nothing -> createItem timed_ live + newGroupContentMessage gInfo m@GroupMember {localDisplayName = c, memberId, memberRole} mc msg@RcvMessage {sharedMsgId_} msgMeta = do + assertMemberSendAllowed gInfo m msgScope $ rejected GFDirectMessages >> directMsgProhibitedErr + processMessage where + processMessage + | isVoice content && not (groupFeatureAllowed SGFVoice gInfo) = rejected GFVoice + | not (isVoice content) && isJust fInv_ && not (groupFeatureAllowed SGFFiles gInfo) = rejected GFFiles + | otherwise = do + -- TODO integrity message check + -- check if message moderation event was received ahead of message + let timed_ = rcvGroupCITimed gInfo itemTTL + live = fromMaybe False live_ + case msgScope_ of + Nothing -> processGroupScopeMsg timed_ live + Just MSGroup -> processGroupScopeMsg timed_ live + Just MSDirect -> createItem timed_ live + processGroupScopeMsg timed_ live = + withStore' (\db -> getCIModeration db user gInfo memberId sharedMsgId_) >>= \case + Just ciModeration -> do + applyModeration timed_ live ciModeration + withStore' $ \db -> deleteCIModeration db gInfo memberId sharedMsgId_ + Nothing -> createItem timed_ live rejected f = void $ newChatItem (CIRcvGroupFeatureRejected f) Nothing Nothing False - ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc + ExtMsgContent content fInv_ itemTTL live_ msgScope_ = mcExtMsgContent mc + msgScope = fromMaybe MSGroup msgScope_ applyModeration timed_ live CIModeration {moderatorMember = moderator@GroupMember {memberRole = moderatorRole}, createdByMsgId, moderatedAt} | moderatorRole < GRAdmin || moderatorRole < memberRole = createItem timed_ live | groupFeatureAllowed SGFFullDelete gInfo = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False ci' <- withStore' $ \db -> updateGroupChatItemModerated db user gInfo (CChatItem SMDRcv ci) moderator moderatedAt toView $ CRNewChatItem user ci' | otherwise = do file_ <- processFileInvitation fInv_ content $ \db -> createRcvGroupFileTransfer db userId m - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False cr <- markGroupCIDeleted user gInfo (CChatItem SMDRcv ci) createdByMsgId False (Just moderator) moderatedAt toView cr createItem timed_ live = do @@ -3841,24 +3935,39 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do showMsgToast ("#" <> g <> " " <> c <> "> ") content formattedText setActive $ ActiveG g newChatItem ciContent ciFile_ timed_ live = do - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m msgScope) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live reactions <- maybe (pure []) (\sharedMsgId -> withStore' $ \db -> getGroupCIReactions db gInfo memberId sharedMsgId) sharedMsgId_ groupMsgToView gInfo m ci {reactions} msgMeta pure ci + assertMemberSendAllowed :: GroupInfo -> GroupMember -> MessageScope -> m () -> m () + assertMemberSendAllowed + gInfo@GroupInfo {membership = GroupMember {memberRole = userRole}} + m@GroupMember {memberRole} + MSDirect + directMessagesProhibitedAction + | userRole >= GRAdmin || memberRole >= GRAdmin = assertMemberStatus m + | not (groupFeatureAllowed SGFDirectMessages gInfo) = directMessagesProhibitedAction + | otherwise = assertMemberGroupRole m GRAuthor + assertMemberSendAllowed _ m MSGroup _ = + assertMemberGroupRole m GRAuthor + + directMsgProhibitedErr :: m () + directMsgProhibitedErr = throwChatError $ CECommandError "direct messages not allowed" + + assertMemberGroupRole :: GroupMember -> GroupMemberRole -> m () + assertMemberGroupRole member requiredRole = do + when (memberRole (member :: GroupMember) < requiredRole) $ messageError "member is not allowed to send messages (member role)" + assertMemberStatus member + + assertMemberStatus :: GroupMember -> m () + assertMemberStatus member = + when (memberRemoved member) $ messageError "member is not allowed to send messages (member removed)" + groupMessageUpdate :: GroupInfo -> GroupMember -> SharedMsgId -> MsgContent -> RcvMessage -> MsgMeta -> Maybe Int -> Maybe Bool -> m () - groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} m@GroupMember {groupMemberId, memberId} sharedMsgId mc msg@RcvMessage {msgId} msgMeta ttl_ live_ = - updateRcvChatItem `catchCINotFound` \_ -> do - -- This patches initial sharedMsgId into chat item when locally deleted chat item - -- received an update from the sender, so that it can be referenced later (e.g. by broadcast delete). - -- Chat item and update message which created it will have different sharedMsgId in this case... - let timed_ = rcvGroupCITimed gInfo ttl_ - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg (Just sharedMsgId) msgMeta content Nothing timed_ live - ci' <- withStore' $ \db -> do - createChatItemVersion db (chatItemId' ci) brokerTs mc - updateGroupChatItem db user groupId ci content live Nothing - toView $ CRChatItemUpdated user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci') - setActive $ ActiveG g + groupMessageUpdate gInfo@GroupInfo {groupId, localDisplayName = g} GroupMember {groupMemberId, memberId} sharedMsgId mc RcvMessage {msgId} msgMeta _ttl_ live_ = + updateRcvChatItem `catchCINotFound` \_ -> + withStore' (`deleteMessage` msgId) where MsgMeta {broker = (_, brokerTs)} = msgMeta content = CIRcvMsgContent mc @@ -3866,9 +3975,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do updateRcvChatItem = do cci <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId case cci of - CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> + CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m' msgScope, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> if sameMemberId memberId m' then do + assertMemberSendAllowed gInfo m' msgScope directMsgProhibitedErr let changed = mc /= oldMC if changed || fromMaybe False itemLive then do @@ -3888,10 +3998,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let msgMemberId = fromMaybe memberId sndMemberId_ withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of - CIGroupRcv mem + CIGroupRcv mem msgScope | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView - | otherwise -> deleteMsg mem ci - CIGroupSnd -> deleteMsg membership ci + | msgScope == MSGroup -> deleteMsg mem ci + | otherwise -> messageError "x.msg.del: private message of another member" + CIGroupSnd directMember + | isNothing directMember -> deleteMsg membership ci + | otherwise -> messageError "x.msg.del: private message sent by user" 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 @@ -3934,7 +4047,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do RcvFileTransfer {fileId, xftpRcvFile} <- withStore $ \db -> createRcvGroupFileTransfer db userId m fInv inline fileChunkSize let fileProtocol = if isJust xftpRcvFile then FPXFTP else FPSMP ciFile = Just $ CIFile {fileId, fileName, fileSize, fileSource = Nothing, fileStatus = CIFSRcvInvitation, fileProtocol} - ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False groupMsgToView gInfo m ci msgMeta let g = groupName' gInfo whenGroupNtfs user gInfo $ do @@ -4043,11 +4156,11 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do xFileCancelGroup :: GroupInfo -> GroupMember -> SharedMsgId -> MsgMeta -> m () xFileCancelGroup g@GroupInfo {groupId} mem@GroupMember {groupMemberId, memberId} sharedMsgId msgMeta = do - checkIntegrityCreateItem (CDGroupRcv g mem) msgMeta + checkIntegrityCreateItem (CDGroupRcv g mem MSGroup) msgMeta fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId CChatItem msgDir ChatItem {chatDir} <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId case (msgDir, chatDir) of - (SMDRcv, CIGroupRcv m) -> do + (SMDRcv, CIGroupRcv m _) -> do if sameMemberId memberId m then do ft <- withStore (\db -> getRcvFileTransfer db user fileId) @@ -4060,7 +4173,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do xFileAcptInvGroup :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe ConnReqInvitation -> String -> MsgMeta -> m () xFileAcptInvGroup g@GroupInfo {groupId} m@GroupMember {activeConn} sharedMsgId fileConnReq_ fName msgMeta = do - checkIntegrityCreateItem (CDGroupRcv g m) msgMeta + checkIntegrityCreateItem (CDGroupRcv g m MSGroup) msgMeta fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId assertSMPAcceptNotProhibited ci @@ -4091,7 +4204,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do groupMsgToView :: GroupInfo -> GroupMember -> ChatItem 'CTGroup 'MDRcv -> MsgMeta -> m () groupMsgToView gInfo m ci msgMeta = do - checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta + checkIntegrityCreateItem (CDGroupRcv gInfo m MSGroup) msgMeta toView $ CRNewChatItem user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m () @@ -4167,7 +4280,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do forM_ allGroupFeatures $ \(AGF f) -> do let p = getGroupPreference f fullGroupPreferences (_, param) = groupFeatureState p - createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing + createInternalChatItem user (CDGroupRcv g m MSGroup) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = @@ -4330,7 +4443,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do then messageError "x.grp.mem.new error: member already exists" else do newMember@GroupMember {groupMemberId} <- withStore $ \db -> createNewGroupMember db user gInfo memInfo GCPostMember GSMemAnnounced - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile) groupMsgToView gInfo m ci msgMeta toView $ CRJoinedGroupMemberConnecting user gInfo m newMember @@ -4414,7 +4527,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions" | otherwise = do withStore' $ \db -> updateGroupMemberRole db user member memRole - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent gEvent) groupMsgToView gInfo m ci msgMeta toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} @@ -4449,7 +4562,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do messageError "x.grp.mem.del with insufficient member permissions" | otherwise = a deleteMemberItem gEvent = do - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent gEvent) groupMsgToView gInfo m ci msgMeta sameMemberId :: MemberId -> GroupMember -> Bool @@ -4460,7 +4573,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do deleteMemberConnection user m -- member record is not deleted to allow creation of "member left" chat item withStore' $ \db -> updateGroupMemberStatus db userId m GSMemLeft - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) groupMsgToView gInfo m ci msgMeta toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft} @@ -4473,7 +4586,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do pure members -- member records are not deleted to keep history deleteMembersConnections user ms - ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m MSGroup) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView gInfo m ci msgMeta toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m @@ -4483,7 +4596,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do | otherwise = unless (p == p') $ do g' <- withStore $ \db -> updateGroupProfile db user g p' toView $ CRGroupUpdated user g g' (Just m) - let cd = CDGroupRcv g' m + let cd = CDGroupRcv g' m MSGroup unless (sameGroupProfileInfo p p') $ do ci <- saveRcvChatItem user cd msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p') groupMsgToView g' m ci msgMeta @@ -4498,7 +4611,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do groupMsgReceived :: GroupInfo -> GroupMember -> Connection -> MsgMeta -> NonEmpty MsgReceipt -> m () groupMsgReceived gInfo m conn@Connection {connId} msgMeta msgRcpts = do - checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta + checkIntegrityCreateItem (CDGroupRcv gInfo m MSGroup) msgMeta forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do withStore $ \db -> createSndMsgDeliveryEvent db connId agentMsgId $ MDSSndRcvd msgRcptStatus updateGroupItemStatus gInfo m conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete @@ -5211,7 +5324,7 @@ chatCommandP = "/_get chat " *> (APIGetChat <$> chatRefP <* A.space <*> chatPaginationP <*> optional (" search=" *> stringP)), "/_get items " *> (APIGetChatItems <$> chatPaginationP <*> optional (" search=" *> stringP)), "/_get item info " *> (APIGetChatItemInfo <$> chatRefP <* A.space <*> A.decimal), - "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), + "/_send " *> (APISendMessage <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" 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), @@ -5335,8 +5448,7 @@ chatCommandP = "/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole), "/delete link #" *> (DeleteGroupLink <$> displayName), "/show link #" *> (ShowGroupLink <$> displayName), - (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP), - (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP), + (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <*> optional (" >@" *> displayName) <*> optional (" @" *> displayName) <* A.space <*> quotedMsg <*> msgTextP), "/_contacts " *> (APIListContacts <$> A.decimal), "/contacts" $> ListContacts, "/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)), @@ -5344,8 +5456,8 @@ chatCommandP = "/_set incognito :" *> (APISetConnectionIncognito <$> A.decimal <* A.space <*> onOffP), ("/connect" <|> "/c") *> (Connect <$> incognitoP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)), ("/connect" <|> "/c") *> (AddContact <$> incognitoP), - SendMessage <$> chatNameP <* A.space <*> msgTextP, - "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")), + SendMessage <$> sendNameP <* A.space <*> msgTextP, + "/live " *> (SendLiveMessage <$> sendNameP <*> (A.space *> msgTextP <|> pure "")), (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), @@ -5360,10 +5472,10 @@ chatCommandP = "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), "/show " *> (ShowChatItem . Just <$> A.decimal), "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP), - ("/file " <|> "/f ") *> (SendFile <$> chatNameP' <* A.space <*> filePath), - ("/image " <|> "/img ") *> (SendImage <$> chatNameP' <* A.space <*> filePath), - ("/fforward " <|> "/ff ") *> (ForwardFile <$> chatNameP' <* A.space <*> A.decimal), - ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> chatNameP' <* A.space <*> A.decimal), + ("/file " <|> "/f ") *> (SendFile <$> sendNameP' <* A.space <*> filePath), + ("/image " <|> "/img ") *> (SendImage <$> sendNameP' <* A.space <*> filePath), + ("/fforward " <|> "/ff ") *> (ForwardFile <$> sendNameP' <* A.space <*> A.decimal), + ("/image_forward " <|> "/imgf ") *> (ForwardImage <$> sendNameP' <* A.space <*> A.decimal), ("/fdescription " <|> "/fd") *> (SendFileDescription <$> chatNameP' <* A.space <*> filePath), ("/freceive " <|> "/fr ") *> (ReceiveFile <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False) <*> optional (" inline=" *> onOffP) <*> optional (A.space *> filePath)), "/_set_file_to_receive " *> (SetFileToReceive <$> A.decimal <*> (" encrypt=" *> onOffP <|> pure False)), @@ -5474,6 +5586,13 @@ chatCommandP = chatNameP = ChatName <$> chatTypeP <*> displayName chatNameP' = ChatName <$> (chatTypeP <|> pure CTDirect) <*> displayName chatRefP = ChatRef <$> chatTypeP <*> A.decimal + sendNameP = + (A.char '@' $> SNDirect <*> displayName) + <|> (A.char '#' $> SNGroup <*> displayName <*> optional (" @" *> displayName)) + sendNameP' = sendNameP <|> (SNDirect <$> displayName) + sendRefP = + (A.char '@' $> SRDirect <*> A.decimal) + <|> (A.char '#' $> SRGroup <*> A.decimal <*> optional (" @" *> A.decimal)) msgCountP = A.space *> A.decimal <|> pure 10 ciTTLDecimal = ("none" $> Nothing) <|> (Just <$> A.decimal) ciTTL = diff --git a/src/Simplex/Chat/Bot.hs b/src/Simplex/Chat/Bot.hs index df9c66cee..50bddbb19 100644 --- a/src/Simplex/Chat/Bot.hs +++ b/src/Simplex/Chat/Bot.hs @@ -67,7 +67,7 @@ sendComposedMessage cc = sendComposedMessage' cc . contactId' sendComposedMessage' :: ChatController -> ContactId -> Maybe ChatItemId -> MsgContent -> IO () sendComposedMessage' cc ctId quotedItemId msgContent = do let cm = ComposedMessage {fileSource = Nothing, quotedItemId, msgContent} - sendChatCmd cc (APISendMessage (ChatRef CTDirect ctId) False Nothing cm) >>= \case + sendChatCmd cc (APISendMessage (SRDirect ctId) False Nothing cm) >>= \case CRNewChatItem {} -> printLog cc CLLInfo $ "sent message to contact ID " <> show ctId r -> putStrLn $ "unexpected send message response: " <> show r diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index af9aa964c..26e4f4356 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -34,6 +34,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.String import Data.Text (Text) +import qualified Data.Text as T import Data.Time (NominalDiffTime) import Data.Time.Clock (UTCTime) import Data.Version (showVersion) @@ -241,7 +242,7 @@ data ChatCommand | APIGetChat ChatRef ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatRef ChatItemId - | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} + | APISendMessage {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId @@ -352,14 +353,14 @@ data ChatCommand | AddressAutoAccept (Maybe AutoAccept) | AcceptContact IncognitoEnabled ContactName | RejectContact ContactName - | SendMessage ChatName Text - | SendLiveMessage ChatName Text + | SendMessage SendName Text + | SendLiveMessage SendName Text | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: Text, message :: Text} | SendMessageBroadcast Text -- UserId (not used in UI) | DeleteMessage ChatName Text | DeleteMemberMessage GroupName ContactName Text | EditMessage {chatName :: ChatName, editedMsg :: Text, message :: Text} - | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text} + | UpdateLiveMessage {sendName :: SendName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text} | ReactToMessage {add :: Bool, reaction :: MsgReaction, chatName :: ChatName, reactToMessage :: Text} | APINewGroup UserId GroupProfile | NewGroup GroupProfile @@ -381,17 +382,17 @@ data ChatCommand | GroupLinkMemberRole GroupName GroupMemberRole | DeleteGroupLink GroupName | ShowGroupLink GroupName - | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: Text, message :: Text} + | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, directMemberName :: Maybe ContactName, quotedMsg :: Text, message :: Text} | LastChats (Maybe Int) -- UserId (not used in UI) | LastMessages (Maybe ChatName) Int (Maybe String) -- UserId (not used in UI) | LastChatItemId (Maybe ChatName) Int -- UserId (not used in UI) | ShowChatItem (Maybe ChatItemId) -- UserId (not used in UI) | ShowChatItemInfo ChatName Text | ShowLiveItems Bool - | SendFile ChatName FilePath - | SendImage ChatName FilePath - | ForwardFile ChatName FileTransferId - | ForwardImage ChatName FileTransferId + | SendFile SendName FilePath + | SendImage SendName FilePath + | ForwardFile SendName FileTransferId + | ForwardImage SendName FileTransferId | SendFileDescription ChatName FilePath | ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath} | SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool} @@ -612,6 +613,37 @@ instance ToJSON ChatResponse where toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "CR" toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "CR" +data SendRef + = SRDirect ContactId + | SRGroup GroupId (Maybe GroupMemberId) + deriving (Eq, Show) + +sendToChatRef :: SendRef -> ChatRef +sendToChatRef = \case + SRDirect cId -> ChatRef CTDirect cId + SRGroup gId _ -> ChatRef CTGroup gId + +data SendName + = SNDirect ContactName + | SNGroup GroupName (Maybe ContactName) + deriving (Eq, Show) + +sendNameStr :: SendName -> String +sendNameStr = \case + SNDirect cName -> "@" <> T.unpack cName + SNGroup gName (Just cName) -> "#" <> T.unpack gName <> " @" <> T.unpack cName + SNGroup gName Nothing -> "#" <> T.unpack gName + +data SendDirection + = SDDirect Contact + | SDGroup GroupInfo [GroupMember] + deriving (Eq, Show) + +sendDirToContactOrGroup :: SendDirection -> ContactOrGroup +sendDirToContactOrGroup = \case + SDDirect c -> CGContact c + SDGroup g _ -> CGGroup g + newtype UserPwd = UserPwd {unUserPwd :: Text} deriving (Eq, Show) @@ -927,6 +959,7 @@ data ChatErrorType | CEAgentCommandError {message :: String} | CEInvalidFileDescription {message :: String} | CEConnectionIncognitoChangeProhibited + | CEPeerChatVRangeIncompatible | CEInternalError {message :: String} | CEException {message :: String} deriving (Show, Exception, Generic) diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 45e5f9ff7..f97a0dd1b 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -50,16 +50,6 @@ data ChatType = CTDirect | CTGroup | CTContactRequest | CTContactConnection data ChatName = ChatName ChatType Text deriving (Show) -chatTypeStr :: ChatType -> String -chatTypeStr = \case - CTDirect -> "@" - CTGroup -> "#" - CTContactRequest -> "<@" - CTContactConnection -> ":" - -chatNameStr :: ChatName -> String -chatNameStr (ChatName cType name) = chatTypeStr cType <> T.unpack name - data ChatRef = ChatRef ChatType Int64 deriving (Eq, Show, Ord) @@ -148,16 +138,16 @@ instance MsgDirectionI d => ToJSON (ChatItem c d) where data CIDirection (c :: ChatType) (d :: MsgDirection) where CIDirectSnd :: CIDirection 'CTDirect 'MDSnd CIDirectRcv :: CIDirection 'CTDirect 'MDRcv - CIGroupSnd :: CIDirection 'CTGroup 'MDSnd - CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv + CIGroupSnd :: Maybe GroupMember -> CIDirection 'CTGroup 'MDSnd + CIGroupRcv :: GroupMember -> MessageScope -> CIDirection 'CTGroup 'MDRcv deriving instance Show (CIDirection c d) data JSONCIDirection = JCIDirectSnd | JCIDirectRcv - | JCIGroupSnd - | JCIGroupRcv {groupMember :: GroupMember} + | JCIGroupSnd {directMember :: Maybe GroupMember} + | JCIGroupRcv {groupMember :: GroupMember, messageScope :: MessageScope} deriving (Generic, Show) instance ToJSON JSONCIDirection where @@ -172,8 +162,19 @@ jsonCIDirection :: CIDirection c d -> JSONCIDirection jsonCIDirection = \case CIDirectSnd -> JCIDirectSnd CIDirectRcv -> JCIDirectRcv - CIGroupSnd -> JCIGroupSnd - CIGroupRcv m -> JCIGroupRcv m + CIGroupSnd dm -> JCIGroupSnd dm + CIGroupRcv m ms -> JCIGroupRcv m ms + +ciDirDirectMember :: CIDirection 'CTGroup d -> Maybe GroupMember +ciDirDirectMember = \case + CIGroupSnd dm -> dm + CIGroupRcv _ MSGroup -> Nothing + CIGroupRcv m MSDirect -> Just m + +directMemberToMsgScope :: Maybe GroupMember -> MessageScope +directMemberToMsgScope = \case + Nothing -> MSGroup + Just _ -> MSDirect data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int} deriving (Show, Generic) @@ -208,8 +209,8 @@ timedDeleteAt' CITimed {deleteAt} = deleteAt chatItemMember :: GroupInfo -> ChatItem 'CTGroup d -> GroupMember chatItemMember GroupInfo {membership} ChatItem {chatDir} = case chatDir of - CIGroupSnd -> membership - CIGroupRcv m -> m + CIGroupSnd _ -> membership + CIGroupRcv m _ -> m ciReactionAllowed :: ChatItem c d -> Bool ciReactionAllowed ChatItem {meta = CIMeta {itemDeleted = Just _}} = False @@ -238,22 +239,22 @@ chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} = data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv - CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd - CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv + CDGroupSnd :: GroupInfo -> Maybe GroupMember -> ChatDirection 'CTGroup 'MDSnd + CDGroupRcv :: GroupInfo -> GroupMember -> MessageScope -> ChatDirection 'CTGroup 'MDRcv toCIDirection :: ChatDirection c d -> CIDirection c d toCIDirection = \case CDDirectSnd _ -> CIDirectSnd CDDirectRcv _ -> CIDirectRcv - CDGroupSnd _ -> CIGroupSnd - CDGroupRcv _ m -> CIGroupRcv m + CDGroupSnd _ dm -> CIGroupSnd dm + CDGroupRcv _ m ms -> CIGroupRcv m ms toChatInfo :: ChatDirection c d -> ChatInfo c toChatInfo = \case CDDirectSnd c -> DirectChat c CDDirectRcv c -> DirectChat c - CDGroupSnd g -> GroupChat g - CDGroupRcv g _ -> GroupChat g + CDGroupSnd g _ -> GroupChat g + CDGroupRcv g _ _ -> GroupChat g data NewChatItem d = NewChatItem { createdByMsgId :: Maybe MessageId, @@ -433,29 +434,39 @@ instance ToJSON (JSONCIReaction c d) where data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect CIQDirectRcv :: CIQDirection 'CTDirect - CIQGroupSnd :: CIQDirection 'CTGroup - CIQGroupRcv :: Maybe GroupMember -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet + CIQGroupSnd :: MessageScope -> CIQDirection 'CTGroup + CIQGroupRcv :: Maybe GroupMember -> MessageScope -> CIQDirection 'CTGroup -- member can be Nothing in case MsgRef has memberId that the user is not notified about yet deriving instance Show (CIQDirection c) +data JSONCIQDirection + = JCIQDirectSnd + | JCIQDirectRcv + | JCIQGroupSnd {messageScope :: MessageScope} + | JCIQGroupRcv {groupMember :: Maybe GroupMember, messageScope :: MessageScope} + deriving (Generic, Show) + +instance ToJSON JSONCIQDirection where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCIQ" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCIQ" + instance ToJSON (CIQDirection c) where toJSON = J.toJSON . jsonCIQDirection toEncoding = J.toEncoding . jsonCIQDirection -jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection +jsonCIQDirection :: CIQDirection c -> JSONCIQDirection jsonCIQDirection = \case - CIQDirectSnd -> Just JCIDirectSnd - CIQDirectRcv -> Just JCIDirectRcv - CIQGroupSnd -> Just JCIGroupSnd - CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m - CIQGroupRcv Nothing -> Nothing + CIQDirectSnd -> JCIQDirectSnd + CIQDirectRcv -> JCIQDirectRcv + CIQGroupSnd ms -> JCIQGroupSnd ms + CIQGroupRcv m ms -> JCIQGroupRcv m ms quoteMsgDirection :: CIQDirection c -> MsgDirection quoteMsgDirection = \case CIQDirectSnd -> MDSnd CIQDirectRcv -> MDRcv - CIQGroupSnd -> MDSnd - CIQGroupRcv _ -> MDRcv + CIQGroupSnd _ -> MDSnd + CIQGroupRcv _ _ -> MDRcv data CIFile (d :: MsgDirection) = CIFile { fileId :: Int64, diff --git a/src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs b/src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs new file mode 100644 index 000000000..6c150b19c --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20230904_item_direct_group_member_id where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230904_item_direct_group_member_id :: Query +m20230904_item_direct_group_member_id = + [sql| +ALTER TABLE chat_items ADD COLUMN item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL; +ALTER TABLE chat_items ADD COLUMN quoted_message_scope TEXT; + +CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items(item_direct_group_member_id); +|] + +down_m20230904_item_direct_group_member_id :: Query +down_m20230904_item_direct_group_member_id = + [sql| +DROP INDEX idx_chat_items_item_direct_group_member_id; + +ALTER TABLE chat_items DROP COLUMN quoted_message_scope; +ALTER TABLE chat_items DROP COLUMN item_direct_group_member_id; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index c71cc9aa9..f9a9309db 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -392,7 +392,9 @@ CREATE TABLE chat_items( timed_delete_at TEXT, item_live INTEGER, item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, - item_deleted_ts TEXT + item_deleted_ts TEXT, + item_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, + quoted_message_scope TEXT ); CREATE TABLE chat_item_messages( chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, @@ -713,3 +715,6 @@ CREATE INDEX idx_chat_items_user_id_item_status ON chat_items( item_status ); CREATE INDEX idx_connections_to_subscribe ON connections(to_subscribe); +CREATE INDEX idx_chat_items_item_direct_group_member_id ON chat_items( + item_direct_group_member_id +); diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 13692b57c..b42ede41c 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -44,7 +44,7 @@ import Simplex.Chat.Types import Simplex.Chat.Types.Util import Simplex.Messaging.Encoding import Simplex.Messaging.Encoding.String -import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) +import Simplex.Messaging.Parsers (dropPrefix, enumJSON, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version hiding (version) @@ -58,6 +58,10 @@ supportedChatVRange = mkVersionRange 1 currentChatVersion groupNoDirectVRange :: VersionRange groupNoDirectVRange = mkVersionRange 2 currentChatVersion +-- version range that supports private messages from members in a group +groupPrivateMessagesVRange :: VersionRange +groupPrivateMessagesVRange = mkVersionRange 2 currentChatVersion + data ConnectionEntity = RcvDirectMsgConnection {entityConnection :: Connection, contact :: Maybe Contact} | RcvGroupMsgConnection {entityConnection :: Connection, groupInfo :: GroupInfo, groupMember :: GroupMember} @@ -158,11 +162,28 @@ instance ToJSON SharedMsgId where toJSON = strToJSON toEncoding = strToJEncoding +data MessageScope = MSGroup | MSDirect + deriving (Eq, Show, Generic) + +instance FromJSON MessageScope where + parseJSON = J.genericParseJSON . enumJSON $ dropPrefix "MS" + +instance ToJSON MessageScope where + toJSON = J.genericToJSON . enumJSON $ dropPrefix "MS" + toEncoding = J.genericToEncoding . enumJSON $ dropPrefix "MS" + +instance ToField MessageScope where + toField = toField . encodeJSON + +instance FromField MessageScope where + fromField = fromTextField_ decodeJSON + data MsgRef = MsgRef { msgId :: Maybe SharedMsgId, sentAt :: UTCTime, sent :: Bool, - memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received + memberId :: Maybe MemberId, -- must be present in all group message references, both referencing sent and received + msgScope :: Maybe MessageScope } deriving (Eq, Show, Generic) @@ -447,7 +468,13 @@ msgContentTag = \case MCFile {} -> MCFile_ MCUnknown {tag} -> MCUnknown_ tag -data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool} +data ExtMsgContent = ExtMsgContent + { content :: MsgContent, + file :: Maybe FileInvitation, + ttl :: Maybe Int, + live :: Maybe Bool, + scope :: Maybe MessageScope + } deriving (Eq, Show) parseMsgContainer :: J.Object -> JT.Parser MsgContainer @@ -456,10 +483,10 @@ parseMsgContainer v = <|> (v .: "forward" >>= \f -> (if f then MCForward else MCSimple) <$> mc) <|> MCSimple <$> mc where - mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" + mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" <*> v .:? "scope" extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent -extMsgContent mc file = ExtMsgContent mc file Nothing Nothing +extMsgContent mc file = ExtMsgContent mc file Nothing Nothing Nothing justTrue :: Bool -> Maybe Bool justTrue True = Just True @@ -503,7 +530,7 @@ msgContainerJSON = \case MCSimple mc -> o $ msgContent mc where o = JM.fromList - msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["content" .= c] + msgContent (ExtMsgContent c file ttl live scope) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) ["content" .= c] instance ToJSON MsgContent where toJSON = \case diff --git a/src/Simplex/Chat/Store/Messages.hs b/src/Simplex/Chat/Store/Messages.hs index ddd59319d..93b9ed612 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -25,6 +25,7 @@ module Simplex.Chat.Store.Messages createRcvMsgDeliveryEvent, createPendingGroupMessage, getPendingGroupMessages, + deleteMessage, deletePendingGroupMessage, deleteOldMessages, updateChatTs, @@ -289,6 +290,10 @@ getPendingGroupMessages db groupMemberId = pendingGroupMessage (msgId, cmEventTag, msgBody, introId_) = PendingGroupMessage {msgId, cmEventTag, msgBody, introId_} +deleteMessage :: DB.Connection -> MessageId -> IO () +deleteMessage db msgId = do + DB.execute db "DELETE FROM messages WHERE message_id = ?" (Only msgId) + deletePendingGroupMessage :: DB.Connection -> Int64 -> MessageId -> IO () deletePendingGroupMessage db groupMemberId messageId = DB.execute db "DELETE FROM pending_group_messages WHERE group_member_id = ? AND message_id = ?" (groupMemberId, messageId) @@ -297,7 +302,7 @@ deleteOldMessages :: DB.Connection -> UTCTime -> IO () deleteOldMessages db createdAtCutoff = do DB.execute db "DELETE FROM messages WHERE created_at <= ?" (Only createdAtCutoff) -type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) +type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId, Maybe MessageScope) updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of @@ -320,14 +325,15 @@ createNewSndChatItem db user chatDirection SndMessage {msgId, sharedMsgId} ciCon createdByMsgId = if msgId == 0 then Nothing else Just msgId quoteRow :: NewQuoteRow quoteRow = case quotedItem of - Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) - Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> - uncurry (quotedSharedMsgId,Just sentAt,Just content,,) $ case chatDir of - CIQDirectSnd -> (Just True, Nothing) - CIQDirectRcv -> (Just False, Nothing) - CIQGroupSnd -> (Just True, Nothing) - CIQGroupRcv (Just GroupMember {memberId}) -> (Just False, Just memberId) - CIQGroupRcv Nothing -> (Just False, Nothing) + Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) + Just CIQuote {chatDir, sharedMsgId = quotedSharedMsgId, sentAt, content} -> do + let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDir of + CIQDirectSnd -> (Just True, Nothing, Nothing) + CIQDirectRcv -> (Just False, Nothing, Nothing) + CIQGroupSnd messageScope -> (Just True, Nothing, Just messageScope) + CIQGroupRcv (Just GroupMember {memberId}) messageScope -> (Just False, Just memberId, Just messageScope) + CIQGroupRcv Nothing messageScope -> (Just False, Nothing, Just messageScope) + (quotedSharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope) createNewRcvChatItem :: DB.Connection -> User -> ChatDirection c 'MDRcv -> RcvMessage -> Maybe SharedMsgId -> CIContent 'MDRcv -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO (ChatItemId, Maybe (CIQuote c)) createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} sharedMsgId_ ciContent timed live itemTs createdAt = do @@ -338,19 +344,20 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar quotedMsg = cmToQuotedMsg chatMsgEvent quoteRow :: NewQuoteRow quoteRow = case quotedMsg of - Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing) - Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId}, content} -> - uncurry (sharedMsgId,Just sentAt,Just content,,) $ case chatDirection of - CDDirectRcv _ -> (Just $ not sent, Nothing) - CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ -> - (Just $ Just userMemberId == memberId, memberId) + Nothing -> (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) + Just QuotedMsg {msgRef = MsgRef {msgId = sharedMsgId, sentAt, sent, memberId, msgScope}, content} -> do + let (quotedSent, quotedMemberId, quotedMsgScope) = case chatDirection of + CDDirectRcv _ -> (Just $ not sent, Nothing, Nothing) + CDGroupRcv GroupInfo {membership = GroupMember {memberId = userMemberId}} _ _ -> + (Just $ Just userMemberId == memberId, memberId, msgScope) + (sharedMsgId, Just sentAt, Just content, quotedSent, quotedMemberId, quotedMsgScope) createNewChatItemNoMsg :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> CIContent d -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItemNoMsg db user chatDirection ciContent = createNewChatItem_ db user chatDirection Nothing Nothing ciContent quoteRow Nothing False where quoteRow :: NewQuoteRow - quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing) + quoteRow = (Nothing, Nothing, Nothing, Nothing, Nothing, Nothing) createNewChatItem_ :: forall c d. MsgDirectionI d => DB.Connection -> User -> ChatDirection c d -> Maybe MessageId -> Maybe SharedMsgId -> CIContent d -> NewQuoteRow -> Maybe CITimed -> Bool -> UTCTime -> UTCTime -> IO ChatItemId createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent quoteRow timed live itemTs createdAt = do @@ -359,12 +366,12 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q [sql| INSERT INTO chat_items ( -- user and IDs - user_id, created_by_msg_id, contact_id, group_id, group_member_id, + user_id, created_by_msg_id, contact_id, group_id, group_member_id, item_direct_group_member_id, -- meta item_sent, item_ts, item_content, item_text, item_status, shared_msg_id, created_at, updated_at, item_live, timed_ttl, timed_delete_at, -- quote - quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id, quoted_message_scope + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) ciId <- insertedRowId db @@ -373,12 +380,16 @@ createNewChatItem_ db User {userId} chatDirection msgId_ sharedMsgId ciContent q where itemRow :: (SMsgDirection d, UTCTime, CIContent d, Text, CIStatus d, Maybe SharedMsgId) :. (UTCTime, UTCTime, Maybe Bool) :. (Maybe Int, Maybe UTCTime) itemRow = (msgDirection @d, itemTs, ciContent, ciContentToText ciContent, ciCreateStatus ciContent, sharedMsgId) :. (createdAt, createdAt, justTrue live) :. ciTimedRow timed - idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) + idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64, Maybe Int64) idsRow = case chatDirection of - CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing) - CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} -> (Nothing, Just groupId, Just groupMemberId) - CDGroupSnd GroupInfo {groupId} -> (Nothing, Just groupId, Nothing) + CDDirectRcv Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing) + CDDirectSnd Contact {contactId} -> (Just contactId, Nothing, Nothing, Nothing) + CDGroupRcv GroupInfo {groupId} GroupMember {groupMemberId} messageScope -> case messageScope of + MSGroup -> (Nothing, Just groupId, Just groupMemberId, Nothing) + MSDirect -> (Nothing, Just groupId, Just groupMemberId, Just groupMemberId) + CDGroupSnd GroupInfo {groupId} directMember -> case directMember of + Nothing -> (Nothing, Just groupId, Nothing, Nothing) + Just GroupMember {groupMemberId} -> (Nothing, Just groupId, Nothing, Just groupMemberId) ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) @@ -388,19 +399,21 @@ insertChatItemMessage_ :: DB.Connection -> ChatItemId -> MessageId -> UTCTime -> insertChatItemMessage_ db ciId msgId ts = DB.execute db "INSERT INTO chat_item_messages (chat_item_id, message_id, created_at, updated_at) VALUES (?,?,?,?)" (ciId, msgId, ts, ts) getChatItemQuote_ :: DB.Connection -> User -> ChatDirection c 'MDRcv -> QuotedMsg -> IO (CIQuote c) -getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = +getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId, msgScope}, content} = case chatDirection of CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) - CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> + CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} _directMember -> case memberId of Just mId - | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId - | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId + | mId == userMemberId -> (`ciQuote` CIQGroupSnd messageScope) <$> getUserGroupChatItemId_ groupId + | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender) messageScope) <$> getGroupChatItemId_ groupId mId | otherwise -> getGroupChatItemQuote_ groupId mId - _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing + _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing messageScope where ciQuote :: Maybe ChatItemId -> CIQDirection c -> CIQuote c ciQuote itemId dir = CIQuote dir itemId msgId sentAt content . parseMaybeMarkdownList $ msgContentText content + messageScope :: MessageScope + messageScope = fromMaybe MSGroup msgScope getDirectChatItemQuote_ :: Int64 -> Bool -> IO (CIQuote 'CTDirect) getDirectChatItemQuote_ contactId userSent = do fmap ciQuoteDirect . maybeFirstRow fromOnly $ @@ -447,8 +460,8 @@ getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRe [":user_id" := userId, ":group_id" := groupId, ":member_id" := mId, ":msg_id" := msgId] where ciQuoteGroup :: [Only (Maybe ChatItemId) :. GroupMemberRow] -> CIQuote 'CTGroup - ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing - ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow + ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing messageScope + ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId $ CIQGroupRcv (Just $ toGroupMember userContactId memberRow) messageScope getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] getChatPreviews db user withPCC = do @@ -556,7 +569,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope, -- quoted GroupMember rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, @@ -564,7 +577,11 @@ getGroupChatPreviews_ db User {userId, userContactId} = do -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences, + -- direct GroupMember + dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category, + dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id, + dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences FROM groups g JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_members mu ON mu.group_id = g.group_id @@ -590,6 +607,8 @@ getGroupChatPreviews_ db User {userId, userContactId} = do LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) + LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id + LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id) WHERE g.user_id = ? AND mu.contact_id = ? ORDER BY i.item_ts DESC |] @@ -967,10 +986,8 @@ toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent where direction sent = if sent then CIQDirectSnd else CIQDirectRcv - -toQuote :: QuoteRow -> Maybe (CIQDirection c) -> Maybe (CIQuote c) -toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = - CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) + toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = + CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) -- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) @@ -1013,37 +1030,60 @@ toDirectChatItemList currentTs (((Just itemId, Just itemTs, Just msgDir, Just it either (const []) (: []) $ toDirectChatItem currentTs (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. quoteRow) toDirectChatItemList _ _ = [] -type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow +type GroupQuoteRow = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MessageScope) -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow +type GroupQuoteMemberRow = GroupQuoteRow :. MaybeGroupMemberRow -toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) -toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow + +toGroupQuote :: GroupQuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) +toGroupQuote qr@(_, _, _, _, quotedSent, msgScope) quotedMember_ = + toQuote qr $ direction quotedSent quotedMember_ where - direction (Just True) _ = Just CIQGroupSnd - direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member - direction (Just False) Nothing = Just $ CIQGroupRcv Nothing + direction (Just True) _ = Just $ CIQGroupSnd messageScope + direction (Just False) (Just member) = Just $ CIQGroupRcv (Just member) messageScope + direction (Just False) Nothing = Just $ CIQGroupRcv Nothing messageScope direction _ _ = Nothing + messageScope = fromMaybe MSGroup msgScope + toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _, _) dir = + CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) -- this function can be changed so it never fails, not only avoid failure on invalid json -toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do +toGroupChatItem :: UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) +toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, itemContentText, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileKey, fileNonce, fileStatus_, fileProtocol_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) = do chatItem $ fromRight invalid $ dbParseACIContent itemContentText where member_ = toMaybeGroupMember userContactId memberRow_ quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ + directMember_ = toMaybeGroupMember userContactId directMemberRow_ invalid = ACIContent msgDir $ CIInvalidJSON itemContentText chatItem itemContent = case (itemContent, itemStatus, member_, fileStatus_) of (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) + Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing + Right $ cItem SMDSnd (CIGroupSnd directMember_) ciStatus ciContent Nothing + -- read of group chat item can be refactored so that direct member is not read for rcv items: + -- if item_direct_group_member_id is equal to group_member_id, then message scope is direct (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) + case directMember_ of + Just directMember + | sameMember member directMember -> + Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent (maybeCIFile fileStatus) + | otherwise -> badItem + Nothing -> + Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent Nothing + case directMember_ of + Just directMember + | sameMember member directMember -> + Right $ cItem SMDRcv (CIGroupRcv member MSDirect) ciStatus ciContent Nothing + | otherwise -> badItem + Nothing -> + Right $ cItem SMDRcv (CIGroupRcv member MSGroup) ciStatus ciContent Nothing _ -> badItem + sameMember :: GroupMember -> GroupMember -> Bool + sameMember GroupMember {groupMemberId = gmId1} GroupMember {groupMemberId = gmId2} = gmId1 == gmId2 maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile fileStatus = case (fileId_, fileName_, fileSize_, fileProtocol_) of @@ -1068,8 +1108,8 @@ toGroupChatItem currentTs userContactId (((itemId, itemTs, AMsgDirection msgDir, ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toGroupChatItemList :: UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = - either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) +toGroupChatItemList currentTs userContactId (((Just itemId, Just itemTs, Just msgDir, Just itemContent, Just itemText, Just itemStatus, sharedMsgId) :. (Just itemDeleted, deletedTs, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) = + either (const []) (: []) $ toGroupChatItem currentTs userContactId (((itemId, itemTs, msgDir, itemContent, itemText, itemStatus, sharedMsgId) :. (itemDeleted, deletedTs, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_ :. directMemberRow_) toGroupChatItemList _ _ _ = [] getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] @@ -1484,7 +1524,7 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do m.member_status, m.invited_by, m.local_display_name, m.contact_id, m.contact_profile_id, p.contact_profile_id, p.display_name, p.full_name, p.image, p.contact_link, p.local_alias, p.preferences, -- quoted ChatItem - ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, i.quoted_message_scope, -- quoted GroupMember rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, rm.member_status, rm.invited_by, rm.local_display_name, rm.contact_id, rm.contact_profile_id, rp.contact_profile_id, @@ -1492,7 +1532,11 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do -- deleted by GroupMember dbm.group_member_id, dbm.group_id, dbm.member_id, dbm.member_role, dbm.member_category, dbm.member_status, dbm.invited_by, dbm.local_display_name, dbm.contact_id, dbm.contact_profile_id, dbp.contact_profile_id, - dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.preferences, + -- direct GroupMember + dirm.group_member_id, dirm.group_id, dirm.member_id, dirm.member_role, dirm.member_category, + dirm.member_status, dirm.invited_by, dirm.local_display_name, dirm.contact_id, dirm.contact_profile_id, dirp.contact_profile_id, + dirp.display_name, dirp.full_name, dirp.image, dirp.contact_link, dirp.local_alias, dirp.preferences FROM chat_items i LEFT JOIN files f ON f.chat_item_id = i.chat_item_id LEFT JOIN group_members m ON m.group_member_id = i.group_member_id @@ -1502,6 +1546,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do LEFT JOIN contact_profiles rp ON rp.contact_profile_id = COALESCE(rm.member_profile_id, rm.contact_profile_id) LEFT JOIN group_members dbm ON dbm.group_member_id = i.item_deleted_by_group_member_id LEFT JOIN contact_profiles dbp ON dbp.contact_profile_id = COALESCE(dbm.member_profile_id, dbm.contact_profile_id) + LEFT JOIN group_members dirm ON dirm.group_member_id = i.item_direct_group_member_id + LEFT JOIN contact_profiles dirp ON dirp.contact_profile_id = COALESCE(dirm.member_profile_id, dirm.contact_profile_id) WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? |] (userId, groupId, itemId) diff --git a/src/Simplex/Chat/Store/Migrations.hs b/src/Simplex/Chat/Store/Migrations.hs index cbcc4ddd2..74e2d89d7 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -79,6 +79,7 @@ import Simplex.Chat.Migrations.M20230814_indexes import Simplex.Chat.Migrations.M20230827_file_encryption import Simplex.Chat.Migrations.M20230829_connections_chat_vrange import Simplex.Chat.Migrations.M20230903_connections_to_subscribe +import Simplex.Chat.Migrations.M20230904_item_direct_group_member_id import Simplex.Messaging.Agent.Store.SQLite.Migrations (Migration (..)) schemaMigrations :: [(String, Query, Maybe Query)] @@ -157,7 +158,8 @@ schemaMigrations = ("20230814_indexes", m20230814_indexes, Just down_m20230814_indexes), ("20230827_file_encryption", m20230827_file_encryption, Just down_m20230827_file_encryption), ("20230829_connections_chat_vrange", m20230829_connections_chat_vrange, Just down_m20230829_connections_chat_vrange), - ("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe) + ("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe), + ("20230904_item_direct_group_member_id", m20230904_item_direct_group_member_id, Just down_m20230904_item_direct_group_member_id) ] -- | The list of migrations in ascending order by date diff --git a/src/Simplex/Chat/Terminal/Input.hs b/src/Simplex/Chat/Terminal/Input.hs index 36cec49d7..f28795a37 100644 --- a/src/Simplex/Chat/Terminal/Input.hs +++ b/src/Simplex/Chat/Terminal/Input.hs @@ -73,19 +73,19 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do Right SendMessageBroadcast {} -> True _ -> False startLiveMessage :: Either a ChatCommand -> ChatResponse -> IO () - startLiveMessage (Right (SendLiveMessage chatName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do + startLiveMessage (Right (SendLiveMessage sendName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do whenM (isNothing <$> readTVarIO liveMessageState) $ do let s = T.unpack msg int = case cType of SCTGroup -> 5000000; _ -> 3000000 :: Int liveThreadId <- mkWeakThreadId =<< runLiveMessage int `forkFinally` const (atomically $ writeTVar liveMessageState Nothing) promptThreadId <- mkWeakThreadId =<< forkIO blinkLivePrompt atomically $ do - let lm = LiveMessage {chatName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId} + let lm = LiveMessage {sendName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId} writeTVar liveMessageState (Just lm) modifyTVar termState $ \ts -> ts {inputString = s, inputPosition = length s, inputPrompt = liveInputPrompt lm} where - liveInputPrompt LiveMessage {chatName = n, livePrompt} = - "> " <> chatNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] " + liveInputPrompt LiveMessage {sendName = n, livePrompt} = + "> " <> sendNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] " runLiveMessage :: Int -> IO () runLiveMessage int = do threadDelay int @@ -123,8 +123,8 @@ runInputLoop ct@ChatTerminal {termState, liveMessageState} cc = forever $ do startLiveMessage _ _ = pure () sendUpdatedLiveMessage :: ChatController -> String -> LiveMessage -> Bool -> IO ChatResponse -sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do - let cmd = UpdateLiveMessage chatName chatItemId live $ T.pack sentMsg +sendUpdatedLiveMessage cc sentMsg LiveMessage {sendName, chatItemId} live = do + let cmd = UpdateLiveMessage sendName chatItemId live $ T.pack sentMsg either (CRChatCmdError Nothing) id <$> runExceptT (processChatCommand cmd) `runReaderT` cc runTerminalInput :: ChatTerminal -> ChatController -> IO () @@ -174,14 +174,14 @@ receiveFromTTY cc@ChatController {inputQ, activeTo, currentUser, chatStore} ct@C let s = inputString ts lm_ <- readTVar liveMessageState case lm_ of - Just LiveMessage {chatName} + Just LiveMessage {sendName} | live -> do writeTVar termState ts' {previousInput} - writeTBQueue inputQ $ "/live " <> chatNameStr chatName + writeTBQueue inputQ $ "/live " <> sendNameStr sendName | otherwise -> writeTVar termState ts' {inputPrompt = "> ", previousInput} where - previousInput = chatNameStr chatName <> " " <> s + previousInput = sendNameStr sendName <> " " <> s _ | live -> when (isSend s) $ do writeTVar termState ts' {previousInput = s} diff --git a/src/Simplex/Chat/Terminal/Output.hs b/src/Simplex/Chat/Terminal/Output.hs index ce68d715f..1a3638028 100644 --- a/src/Simplex/Chat/Terminal/Output.hs +++ b/src/Simplex/Chat/Terminal/Output.hs @@ -55,7 +55,7 @@ data AutoCompleteState = ACState } data LiveMessage = LiveMessage - { chatName :: ChatName, + { sendName :: SendName, chatItemId :: ChatItemId, livePrompt :: Bool, sentMsg :: String, diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index 2d77cbe77..bcef3cbff 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -330,12 +330,12 @@ data GroupSummary = GroupSummary instance ToJSON GroupSummary where toEncoding = J.genericToEncoding J.defaultOptions -data ContactOrGroup = CGContact Contact | CGGroup Group +data ContactOrGroup = CGContact Contact | CGGroup GroupInfo contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId) contactAndGroupIds = \case CGContact Contact {contactId} -> (Just contactId, Nothing) - CGGroup (Group GroupInfo {groupId} _) -> (Nothing, Just groupId) + CGGroup GroupInfo {groupId} -> (Nothing, Just groupId) -- TODO when more settings are added we should create another type to allow partial setting updates (with all Maybe properties) data ChatSettings = ChatSettings diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 1a740bef5..4656ea5b2 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -322,14 +322,35 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView testViewChat :: AChat -> [StyledString] testViewChat (AChat _ Chat {chatInfo, chatItems}) = [sShow $ map toChatView chatItems] where - toChatView :: CChatItem c -> ((Int, Text), Maybe (Int, Text), Maybe String) - toChatView ci@(CChatItem dir ChatItem {quotedItem, file}) = - ((msgDirectionInt $ toMsgDirection dir, testViewItem ci (chatInfoMembership chatInfo)), qItem, fPath) + toChatView :: CChatItem c -> ((Int, String, Text), Maybe (Int, String, Text), Maybe String) + toChatView ci@(CChatItem dir ChatItem {chatDir, quotedItem, file}) = + (item, qItem, fPath) where + item = + ( msgDirectionInt $ toMsgDirection dir, + directMemberName, + testViewItem ci (chatInfoMembership chatInfo) + ) + directMemberName = case chatDir of + CIGroupSnd (Just GroupMember {localDisplayName = n}) -> T.unpack n + CIGroupRcv GroupMember {localDisplayName = n} MSDirect -> T.unpack n + _ -> "" qItem = case quotedItem of Nothing -> Nothing Just CIQuote {chatDir = quoteDir, content} -> - Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content) + Just + ( msgDirectionInt $ quoteMsgDirection quoteDir, + qMsgScope, + msgContentText content + ) + where + qMsgScope = case quoteDir of + CIQGroupSnd ms -> msgScopeText ms + CIQGroupRcv _ ms -> msgScopeText ms + _ -> "" + msgScopeText ms = case ms of + MSGroup -> "group" + MSDirect -> "direct" fPath = case file of Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp _ -> Nothing @@ -380,7 +401,7 @@ viewUsersList = mapMaybe userInfo . sortOn ldn muted :: ChatInfo c -> CIDirection c d -> Bool muted chat chatDir = case (chat, chatDir) of (DirectChat Contact {chatSettings = DisableNtfs}, CIDirectRcv) -> True - (GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _) -> True + (GroupChat GroupInfo {chatSettings = DisableNtfs}, CIGroupRcv _ _) -> True _ -> False viewGroupSubscribed :: GroupInfo -> [StyledString] @@ -403,8 +424,9 @@ viewChats ts tz = concatMap chatPreview . reverse where chatName = case chat of DirectChat ct -> [" " <> ttyToContact' ct] - GroupChat g -> [" " <> ttyToGroup g] + GroupChat g -> [" " <> ttyToGroup' g] _ -> [] + ttyToGroup' g@GroupInfo {localDisplayName = n} = membershipIncognito g <> ttyTo ("#" <> n <> " ") viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> TimeZone -> [StyledString] viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} doShow ts tz = @@ -426,20 +448,20 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} where quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of - CIGroupSnd -> case content of + CIGroupSnd directMember -> case content of CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc CISndGroupInvitation {} -> showSndItemProhibited to _ -> showSndItem to where - to = ttyToGroup g - CIGroupRcv m -> case content of + to = ttyToGroup g directMember + CIGroupRcv m msgScope -> case content of CIRcvMsgContent mc -> withRcvFile from $ rcvMsg from quote mc CIRcvIntegrityError err -> viewRcvIntegrityError from err ts tz meta CIRcvGroupInvitation {} -> showRcvItemProhibited from - CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m msgScope) quote meta [plainContent content] False _ -> showRcvItem from where - from = ttyFromGroup g m + from = ttyFromGroup g m msgScope where quote = maybe [] (groupQuote g) quotedItem _ -> [] @@ -531,18 +553,18 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive} where quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of - CIGroupRcv m -> case content of + CIGroupRcv m msgScope -> case content of CIRcvMsgContent mc | itemLive == Just True && not liveItems -> [] | otherwise -> viewReceivedUpdatedMessage from quote mc ts tz meta _ -> [] where - from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m - CIGroupSnd -> case content of + from = if itemEdited then ttyFromGroupEdited g m msgScope else ttyFromGroup g m msgScope + CIGroupSnd directMember -> case content of CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta _ -> [] where - to = if itemEdited then ttyToGroupEdited g else ttyToGroup g + to = if itemEdited then ttyToGroupEdited g directMember else ttyToGroup g directMember where quote = maybe [] (groupQuote g) quotedItem _ -> [] @@ -567,7 +589,8 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem GroupChat g -> case ciMsgContent deletedContent of Just mc -> let m = chatItemMember g ci - in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta + msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir + in viewReceivedMessage (ttyFromGroupDeleted g m msgScope deletedText_) [] mc ts tz meta _ -> prohibited _ -> prohibited where @@ -586,14 +609,14 @@ viewItemReaction showReactions chat CIReaction {chatDir, chatItem = CChatItem md where from = ttyFromContact c reactionMsg mc = quoteText mc $ if toMsgDirection md == MDSnd then ">>" else ">" - (GroupChat g, CIGroupRcv m) -> case ciMsgContent content of + (GroupChat g, CIGroupRcv m messageScope) -> case ciMsgContent content of Just mc -> view from $ reactionMsg mc _ -> [] where - from = ttyFromGroup g m + from = ttyFromGroup g m messageScope reactionMsg mc = quoteText mc . ttyQuotedMember . Just $ sentByMember' g itemDir (_, CIDirectSnd) -> [sentText] - (_, CIGroupSnd) -> [sentText] + (_, CIGroupSnd _) -> [sentText] where view from msg | showReactions = viewReceivedReaction from msg reactionText ts tz sentAt @@ -621,13 +644,13 @@ groupQuote g CIQuote {content = qmc, chatDir = quoteDir} = quoteText qmc . ttyQu sentByMember :: GroupInfo -> CIQDirection 'CTGroup -> Maybe GroupMember sentByMember GroupInfo {membership} = \case - CIQGroupSnd -> Just membership - CIQGroupRcv m -> m + CIQGroupSnd _ -> Just membership + CIQGroupRcv m _ -> m sentByMember' :: GroupInfo -> CIDirection 'CTGroup d -> GroupMember sentByMember' GroupInfo {membership} = \case - CIGroupSnd -> membership - CIGroupRcv m -> m + CIGroupSnd _ -> membership + CIGroupRcv m _ -> m quoteText :: MsgContent -> StyledString -> [StyledString] quoteText qmc sentBy = prependFirst (sentBy <> " ") $ msgPreview qmc @@ -1319,8 +1342,9 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = uploadingFile :: StyledString -> AChatItem -> [StyledString] uploadingFile status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectSnd}) = [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyContact c] -uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) = - [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g] +uploadingFile status (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd directMember}) = + let forMember = maybe "" (\GroupMember {localDisplayName = m} -> styled (colored Blue) $ " @" <> m <> " (direct)") directMember + in [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g <> forMember] uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen sndFile :: SndFileTransfer -> StyledString @@ -1352,7 +1376,7 @@ savingFile' :: Bool -> AChatItem -> [StyledString] savingFile' testView (AChatItem _ _ chat ChatItem {file = Just CIFile {fileId, fileSource = Just (CryptoFile filePath cfArgs_)}, chatDir}) = let from = case (chat, chatDir) of (DirectChat Contact {localDisplayName = c}, CIDirectRcv) -> " from " <> ttyContact c - (_, CIGroupRcv GroupMember {localDisplayName = m}) -> " from " <> ttyContact m + (_, CIGroupRcv GroupMember {localDisplayName = m} _) -> " from " <> ttyContact m _ -> "" in ["saving file " <> sShow fileId <> from <> " to " <> plain filePath] <> cfArgsStr where @@ -1366,7 +1390,7 @@ savingFile' _ _ = ["saving file"] -- shouldn't happen receivingFile_' :: StyledString -> AChatItem -> [StyledString] receivingFile_' status (AChatItem _ _ (DirectChat Contact {localDisplayName = c}) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIDirectRcv}) = [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact c] -receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m}}) = +receivingFile_' status (AChatItem _ _ _ ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupRcv GroupMember {localDisplayName = m} _}) = [status <> " receiving " <> fileTransferStr fileId fileName <> " from " <> ttyContact m] receivingFile_' status _ = [status <> " receiving file"] -- shouldn't happen @@ -1582,7 +1606,7 @@ viewChatError logLevel = \case CEXFTPSndFile fileId aFileId e -> ["error sending XFTP file " <> sShow fileId <> ", agent file id " <> sShow aFileId <> ": " <> sShow e | logLevel == CLLError] CEFallbackToSMPProhibited fileId -> ["recipient tried to accept file " <> sShow fileId <> " via old protocol, prohibited"] CEInlineFileProhibited _ -> ["A small file sent without acceptance - you can enable receiving such files with -f option."] - CEInvalidQuote -> ["cannot reply to this message"] + CEInvalidQuote -> ["invalid message reply"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] @@ -1597,6 +1621,7 @@ viewChatError logLevel = \case CEAgentCommandError e -> ["agent command error: " <> plain e] CEInvalidFileDescription e -> ["invalid file description: " <> plain e] CEConnectionIncognitoChangeProhibited -> ["incognito mode change prohibited"] + CEPeerChatVRangeIncompatible -> ["peer chat protocol version range incompatible"] CEInternalError e -> ["internal chat error: " <> plain e] CEException e -> ["exception: " <> plain e] -- e -> ["chat error: " <> sShow e] @@ -1737,19 +1762,24 @@ ttyFullGroup :: GroupInfo -> StyledString ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} = ttyGroup g <> optFullName g fullName -ttyFromGroup :: GroupInfo -> GroupMember -> StyledString -ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m) +ttyFromGroup :: GroupInfo -> GroupMember -> MessageScope -> StyledString +ttyFromGroup g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms) -ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString -ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") +ttyFromGroupEdited :: GroupInfo -> GroupMember -> MessageScope -> StyledString +ttyFromGroupEdited g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> "[edited] ") -ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString -ttyFromGroupDeleted g m deletedText_ = - membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) +ttyFromGroupDeleted :: GroupInfo -> GroupMember -> MessageScope -> Maybe Text -> StyledString +ttyFromGroupDeleted g m ms deletedText_ = + membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) -fromGroup_ :: GroupInfo -> GroupMember -> Text -fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = - "#" <> g <> " " <> m <> "> " +fromGroup_ :: GroupInfo -> GroupMember -> MessageScope -> Text +fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} ms = + "#" <> g <> " " <> m <> fromGroupScope ms <> "> " + +fromGroupScope :: MessageScope -> Text +fromGroupScope = \case + MSGroup -> "" + MSDirect -> " (direct)" ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow @@ -1757,13 +1787,18 @@ ttyFrom = styled $ colored Yellow ttyTo :: Text -> StyledString ttyTo = styled $ colored Cyan -ttyToGroup :: GroupInfo -> StyledString -ttyToGroup g@GroupInfo {localDisplayName = n} = - membershipIncognito g <> ttyTo ("#" <> n <> " ") +ttyToGroup :: GroupInfo -> Maybe GroupMember -> StyledString +ttyToGroup g@GroupInfo {localDisplayName = n} dirMem = + membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " ") -ttyToGroupEdited :: GroupInfo -> StyledString -ttyToGroupEdited g@GroupInfo {localDisplayName = n} = - membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ") +ttyToGroupEdited :: GroupInfo -> Maybe GroupMember -> StyledString +ttyToGroupEdited g@GroupInfo {localDisplayName = n} dirMem = + membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " [edited] ") + +toDirectMember :: Maybe GroupMember -> Text +toDirectMember = \case + Nothing -> "" + Just GroupMember {localDisplayName = m} -> " @" <> m <> " (direct)" ttyFilePath :: FilePath -> StyledString ttyFilePath = plain diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 9e5d4fe1c..de6353d2e 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -259,7 +259,7 @@ getTermLine cc = Just s -> do -- remove condition to always echo virtual terminal when (printOutput cc) $ do - -- when True $ do + -- when True $ do name <- userName cc putStrLn $ name <> ": " <> s pure s diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index d476285fc..6c804659e 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -8,8 +8,9 @@ import ChatTests.Utils import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) import Control.Monad (when) +import qualified Data.ByteString.Char8 as B import qualified Data.Text as T -import Simplex.Chat.Controller (ChatConfig (..)) +import Simplex.Chat.Controller (ChatConfig (..), XFTPFileConfig (..)) import Simplex.Chat.Protocol (supportedChatVRange) import Simplex.Chat.Store (agentStoreFile, chatStoreFile) import Simplex.Chat.Types (GroupMemberRole (..)) @@ -81,6 +82,21 @@ chatGroupTests = do testNoDirect4 _1 _0 _1 False False False -- False False True testNoDirect4 _1 _1 _0 False False False testNoDirect4 _1 _1 _1 False False False + describe "group direct messages" $ do + it "should send group direct messages" testGroupDirectMessages + it "should create group direct messages chat items" testGroupDirectMessagesItems + it "should send group direct quotes" testGroupDirectQuotes + it "should create group direct quotes chat items" testGroupDirectQuotesItems + it "should send group direct XFTP files" testGroupDirectFilesXFTP + it "should send group direct SMP files" testGroupDirectFilesSMP + it "should cancel sent group direct XFTP file" testGroupDirectCancelFileXFTP + it "should send group direct quotes with files" testGroupDirectQuotesFiles + it "should update group direct message" testGroupDirectUpdate + it "should delete group direct message" testGroupDirectDelete + it "should send group direct live message" testGroupDirectLiveMessage + it "should send group direct message reactions" testGroupDirectReactions + it "should prohibit group direct messages based on preference" testGroupDirectProhibitPreference + it "should prohibit group direct messages if peer version doesn't support" testGroupDirectProhibitNotSupported where _0 = supportedChatVRange -- don't create direct connections _1 = groupCreateDirectVRange @@ -804,7 +820,7 @@ testGroupMessageQuotedReply = (bob <# "#team alice> hello! how are you?") (cath <# "#team alice> hello! how are you?") threadDelay 1000000 - bob `send` "> #team @alice (hello) hello, all good, you?" + bob `send` "> #team >@alice (hello) hello, all good, you?" bob <# "#team > alice hello! how are you?" bob <## " hello, all good, you?" concurrently_ @@ -819,7 +835,7 @@ testGroupMessageQuotedReply = bob #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((1, "hello, all good, you?"), Just (0, "hello! how are you?"))]) alice #$> ("/_get chat #1 count=2", chat', [((1, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (1, "hello! how are you?"))]) cath #$> ("/_get chat #1 count=2", chat', [((0, "hello! how are you?"), Nothing), ((0, "hello, all good, you?"), Just (0, "hello! how are you?"))]) - bob `send` "> #team bob (hello, all good) will tell more" + bob `send` "> #team >@bob (hello, all good) will tell more" bob <# "#team > bob hello, all good, you?" bob <## " will tell more" concurrently_ @@ -835,7 +851,7 @@ testGroupMessageQuotedReply = alice #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))]) cath #$> ("/_get chat #1 count=1", chat', [((0, "will tell more"), Just (0, "hello, all good, you?"))]) threadDelay 1000000 - cath `send` "> #team bob (hello) hi there!" + cath `send` "> #team >@bob (hello) hi there!" cath <# "#team > bob hello, all good, you?" cath <## " hi there!" concurrently_ @@ -891,7 +907,7 @@ testGroupMessageUpdate = threadDelay 1000000 -- alice, bob: msg id 6, cath: msg id 5 - bob `send` "> #team @alice (hey) hi alice" + bob `send` "> #team >@alice (hey) hi alice" bob <# "#team > alice hey 👋" bob <## " hi alice" concurrently_ @@ -918,7 +934,7 @@ testGroupMessageUpdate = alice #$> ("/_update item #1 " <> msgItemId2 <> " text updating bob's message", id, "cannot update this item") threadDelay 1000000 - cath `send` "> #team @alice (greetings) greetings!" + cath `send` "> #team >@alice (greetings) greetings!" cath <# "#team > alice greetings 🤝" cath <## " greetings!" concurrently_ @@ -994,7 +1010,6 @@ testGroupMessageEditHistory = alice ##> ("/_update item #1 " <> aliceItemId <> " text hey there") alice <# "#team [edited] hey there" - bob <# "#team alice> [edited] hey there" alice ##> "/item info #team hey" alice <##. "sent at: " @@ -1004,10 +1019,7 @@ testGroupMessageEditHistory = alice .<## ": hey 👋" alice .<## ": hello!" bob ##> "/item info #team hey" - bob <##. "sent at: " - bob <##. "received at: " - bob <## "message history:" - bob .<## ": hey there" + bob <## "message not found by text: hey" testGroupMessageDelete :: HasCallStack => FilePath -> IO () testGroupMessageDelete = @@ -1031,7 +1043,7 @@ testGroupMessageDelete = threadDelay 1000000 -- alice: msg id 5, bob: msg id 6, cath: msg id 5 - bob `send` "> #team @alice (hello) hi alic" + bob `send` "> #team >@alice (hello) hi alic" bob <# "#team > alice hello!" bob <## " hi alic" concurrently_ @@ -1060,14 +1072,10 @@ testGroupMessageDelete = bob ##> ("/_update item #1 " <> msgItemId3 <> " text hi alice") bob <# "#team [edited] > alice hello!" bob <## " hi alice" - concurrently_ - (alice <# "#team bob> [edited] hi alice") - ( do - cath <# "#team bob> [edited] > alice hello!" - cath <## " hi alice" - ) + cath <# "#team bob> [edited] > alice hello!" + cath <## " hi alice" - alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alice"), Nothing)]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)]) bob #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((1, "hi alice"), Just (0, "hello!"))]) cath #$> ("/_get chat #1 count=2", chat', [((0, "hello!"), Nothing), ((0, "hi alice"), Just (0, "hello!"))]) @@ -2686,3 +2694,534 @@ testNoGroupDirectConns4Members hostVRange mem2VRange mem3VRange mem4VRange noCon cc1 <## ("no contact " <> name2) cc2 ##> ("@" <> name1 <> " hi") cc2 <## ("no contact " <> name1) + +testGroupDirectMessages :: HasCallStack => FilePath -> IO () +testGroupDirectMessages = + testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do + createGroup3 "team" alice bob cath + connectUsers alice dan + addMember "team" alice dan GRMember + dan ##> "/j team" + concurrentlyN_ + [ alice <## "#team: dan joined the group", + do + dan <## "#team: you joined the group" + dan + <### [ "#team: member bob (Bob) is connected", + "#team: member cath (Catherine) is connected" + ], + aliceAddedDan bob, + aliceAddedDan cath + ] + + alice #> "#team hi" + bob <# "#team alice> hi" + cath <# "#team alice> hi" + dan <# "#team alice> hi" + + alice `send` "#team @bob hi bob" + alice <# "#team @bob (direct) hi bob" + bob <# "#team alice (direct)> hi bob" + + bob `send` "#team @alice hi alice" + bob <# "#team @alice (direct) hi alice" + alice <# "#team bob (direct)> hi alice" + + dan #> "#team hello" + alice <# "#team dan> hello" + bob <# "#team dan> hello" + cath <# "#team dan> hello" + + bob `send` "#team @cath hi cath" + bob <# "#team @cath (direct) hi cath" + cath <# "#team bob (direct)> hi cath" + + cath `send` "#team @bob hello bob" + cath <# "#team @bob (direct) hello bob" + bob <# "#team cath (direct)> hello bob" + where + aliceAddedDan :: HasCallStack => TestCC -> IO () + aliceAddedDan cc = do + cc <## "#team: alice added dan (Daniel) to the group (connecting...)" + cc <## "#team: new member dan is connected" + +testGroupDirectMessagesItems :: HasCallStack => FilePath -> IO () +testGroupDirectMessagesItems = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + threadDelay 1000000 + + alice #> "#team hi" + bob <# "#team alice> hi" + cath <# "#team alice> hi" + threadDelay 1000000 + + alice `send` "#team @bob hi bob" + alice <# "#team @bob (direct) hi bob" + bob <# "#team alice (direct)> hi bob" + threadDelay 1000000 + + bob `send` "#team @alice hi alice" + bob <# "#team @alice (direct) hi alice" + alice <# "#team bob (direct)> hi alice" + threadDelay 1000000 + + alice #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (1, "", "hi"), (1, "bob", "hi bob"), (0, "bob", "hi alice")]) + bob #$> ("/_get chat #1 count=4", mapChat, [(0, "", "connected"), (0, "", "hi"), (0, "alice", "hi bob"), (1, "alice", "hi alice")]) + cath #$> ("/_get chat #1 count=2", mapChat, [(0, "", "connected"), (0, "", "hi")]) + where + mapChat = map (\(a, _, _) -> a) . chat''' + +testGroupDirectQuotes :: HasCallStack => FilePath -> IO () +testGroupDirectQuotes = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice #> "#team 1-g-a" + bob <# "#team alice> 1-g-a" + cath <# "#team alice> 1-g-a" + + bob #> "#team 2-g-b" + alice <# "#team bob> 2-g-b" + cath <# "#team bob> 2-g-b" + + cath #> "#team 3-g-c" + alice <# "#team cath> 3-g-c" + bob <# "#team cath> 3-g-c" + + alice `send` "#team @bob 4-p-ab" + alice <# "#team @bob (direct) 4-p-ab" + bob <# "#team alice (direct)> 4-p-ab" + + bob `send` "#team @alice 5-p-ba" + bob <# "#team @alice (direct) 5-p-ba" + alice <# "#team bob (direct)> 5-p-ba" + + alice `send` "#team @cath 6-p-ac" + alice <# "#team @cath (direct) 6-p-ac" + cath <# "#team alice (direct)> 6-p-ac" + + cath `send` "#team @alice 7-p-ca" + cath <# "#team @alice (direct) 7-p-ca" + alice <# "#team cath (direct)> 7-p-ca" + + -- quotes + + alice `send` "> #team @bob (1-g-a) 8-pq-ab" + alice <# "#team @bob (direct) > alice 1-g-a" + alice <## " 8-pq-ab" + bob <# "#team alice (direct)> > alice 1-g-a" + bob <## " 8-pq-ab" + + alice `send` "> #team @bob (2-g-b) 9-pq-ab" + alice <# "#team @bob (direct) > bob 2-g-b" + alice <## " 9-pq-ab" + bob <# "#team alice (direct)> > bob 2-g-b" + bob <## " 9-pq-ab" + + alice `send` "> #team >@cath @bob (3-g-c) 10-pq-ab" + alice <# "#team @bob (direct) > cath 3-g-c" + alice <## " 10-pq-ab" + bob <# "#team alice (direct)> > cath 3-g-c" + bob <## " 10-pq-ab" + + alice `send` "> #team @bob (4-p-ab) 11-pq-ab" + alice <# "#team @bob (direct) > alice 4-p-ab" + alice <## " 11-pq-ab" + bob <# "#team alice (direct)> > alice 4-p-ab" + bob <## " 11-pq-ab" + + alice `send` "> #team >@bob @bob (5-p-ba) 12-pq-ab" + alice <# "#team @bob (direct) > bob 5-p-ba" + alice <## " 12-pq-ab" + bob <# "#team alice (direct)> > bob 5-p-ba" + bob <## " 12-pq-ab" + + alice `send` "> #team @bob (6-p-ac) 13-pq-ab" + alice <## "> #team @bob (6-p-ac) 13-pq-ab" + alice <## "invalid message reply" + + alice `send` "> #team @bob (7-p-ca) 14-pq-ab" + alice <## "> #team @bob (7-p-ca) 14-pq-ab" + alice <## "invalid message reply" + + alice `send` "> #team (4-p-ab) 15-gq-a" + alice <## "> #team (4-p-ab) 15-gq-a" + alice <## "invalid message reply" + + alice `send` "> #team (5-p-ba) 16-gq-a" + alice <## "> #team (5-p-ba) 16-gq-a" + alice <## "invalid message reply" + +testGroupDirectQuotesItems :: HasCallStack => FilePath -> IO () +testGroupDirectQuotesItems = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice #> "#team 1-g-a" + bob <# "#team alice> 1-g-a" + cath <# "#team alice> 1-g-a" + + alice `send` "#team @bob 2-p-ab" + alice <# "#team @bob (direct) 2-p-ab" + bob <# "#team alice (direct)> 2-p-ab" + + bob `send` "#team @alice 3-p-ba" + bob <# "#team @alice (direct) 3-p-ba" + alice <# "#team bob (direct)> 3-p-ba" + threadDelay 1000000 + + -- quotes + + alice `send` "> #team @bob (1-g-a) 4-pq-ab" + alice <# "#team @bob (direct) > alice 1-g-a" + alice <## " 4-pq-ab" + bob <# "#team alice (direct)> > alice 1-g-a" + bob <## " 4-pq-ab" + threadDelay 1000000 + + alice `send` "> #team @bob (2-p-ab) 5-pq-ab" + alice <# "#team @bob (direct) > alice 2-p-ab" + alice <## " 5-pq-ab" + bob <# "#team alice (direct)> > alice 2-p-ab" + bob <## " 5-pq-ab" + threadDelay 1000000 + + alice `send` "> #team >@bob @bob (3-p-ba) 6-pq-ab" + alice <# "#team @bob (direct) > bob 3-p-ba" + alice <## " 6-pq-ab" + bob <# "#team alice (direct)> > bob 3-p-ba" + bob <## " 6-pq-ab" + + alice + #$> ( "/_get chat #1 count=3", + mapChat, + [ ((1, "bob", "4-pq-ab"), Just (1, "group", "1-g-a")), + ((1, "bob", "5-pq-ab"), Just (1, "direct", "2-p-ab")), + ((1, "bob", "6-pq-ab"), Just (0, "direct", "3-p-ba")) + ] + ) + bob + #$> ( "/_get chat #1 count=3", + mapChat, + [ ((0, "alice", "4-pq-ab"), Just (0, "group", "1-g-a")), + ((0, "alice", "5-pq-ab"), Just (0, "direct", "2-p-ab")), + ((0, "alice", "6-pq-ab"), Just (1, "direct", "3-p-ba")) + ] + ) + where + mapChat = map (\(a, b, _) -> (a, b)) . chat''' + +testGroupDirectFilesXFTP :: HasCallStack => FilePath -> IO () +testGroupDirectFilesXFTP = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do + withXFTPServer $ do + createGroup3 "team" alice bob cath + threadDelay 1000000 + + alice `send` "/f #team @bob ./tests/fixtures/test.pdf" + alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)" + + bob ##> "/fr 1 ./tests/tmp" + bob + <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] + bob <## "completed receiving file 1 (test.pdf) from alice" + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/test.pdf" + dest `shouldBe` src + + cath "/fr 1 ./tests/tmp" + cath <##. "chat db error: SEUserNotFoundByFileId" + + alice `send` "/f #team @cath ./tests/fixtures/test.jpg" + alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg" + alice <## "use /fc 2 to cancel sending" + cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + alice <## "completed uploading file 2 (test.jpg) for #team @cath (direct)" + + cath ##> "/fr 1 ./tests/tmp" + cath + <### [ "saving file 1 from alice to ./tests/tmp/test.jpg", + "started receiving file 1 (test.jpg) from alice" + ] + cath <## "completed receiving file 1 (test.jpg) from alice" + + src2 <- B.readFile "./tests/fixtures/test.jpg" + dest2 <- B.readFile "./tests/tmp/test.jpg" + dest2 `shouldBe` src2 + + bob ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")]) + bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")]) + cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")]) + where + cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"} + mapChat = map (\(a, _, c) -> (a, c)) . chat''' + +testGroupDirectFilesSMP :: HasCallStack => FilePath -> IO () +testGroupDirectFilesSMP = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + threadDelay 1000000 + + alice `send` "/f #team @bob ./tests/fixtures/test.pdf" + alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + bob ##> "/fr 1 ./tests/tmp" + bob <## "saving file 1 from alice to ./tests/tmp/test.pdf" + concurrently_ + (alice <## "started sending file 1 (test.pdf) to bob") + (bob <## "started receiving file 1 (test.pdf) from alice") + concurrently_ + (alice <## "completed sending file 1 (test.pdf) to bob") + (bob <## "completed receiving file 1 (test.pdf) from alice") + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/test.pdf" + dest `shouldBe` src + + cath "/fr 1 ./tests/tmp" + cath <##. "chat db error: SEUserNotFoundByFileId" + + alice `send` "/f #team @cath ./tests/fixtures/test.jpg" + alice <# "/f #team @cath (direct) ./tests/fixtures/test.jpg" + alice <## "use /fc 2 to cancel sending" + cath <# "#team alice (direct)> sends file test.jpg (136.5 KiB / 139737 bytes)" + cath <## "use /fr 1 [/ | ] to receive it" + cath ##> "/fr 1 ./tests/tmp" + cath <## "saving file 1 from alice to ./tests/tmp/test.jpg" + concurrently_ + (alice <## "started sending file 2 (test.jpg) to cath") + (cath <## "started receiving file 1 (test.jpg) from alice") + concurrently_ + (alice <## "completed sending file 2 (test.jpg) to cath") + (cath <## "completed receiving file 1 (test.jpg) from alice") + + src2 <- B.readFile "./tests/fixtures/test.jpg" + dest2 <- B.readFile "./tests/tmp/test.jpg" + dest2 `shouldBe` src2 + + bob ("/_get chat #1 count=2", mapChat, [((1, "bob", ""), Just "./tests/fixtures/test.pdf"), ((1, "cath", ""), Just "./tests/fixtures/test.jpg")]) + bob #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.pdf")]) + cath #$> ("/_get chat #1 count=2", mapChat, [((0, "", "connected"), Nothing), ((0, "alice", ""), Just "./tests/tmp/test.jpg")]) + where + mapChat = map (\(a, _, c) -> (a, c)) . chat''' + +testGroupDirectCancelFileXFTP :: HasCallStack => FilePath -> IO () +testGroupDirectCancelFileXFTP = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do + withXFTPServer $ do + createGroup3 "team" alice bob cath + + alice `send` "/f #team @bob ./tests/fixtures/test.pdf" + alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)" + + cath "/fc 1" + alice <## "cancelled sending file 1 (test.pdf) to bob" + bob <## "alice cancelled sending file 1 (test.pdf)" + + cath "/fr 1 ./tests/tmp" + bob <## "file cancelled: test.pdf" + + cath ##> "/fr 1 ./tests/tmp" + cath <##. "chat db error: SEUserNotFoundByFileId" + where + cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"} + +testGroupDirectQuotesFiles :: HasCallStack => FilePath -> IO () +testGroupDirectQuotesFiles = + testChatCfg3 cfg aliceProfile bobProfile cathProfile $ \alice bob cath -> do + withXFTPServer $ do + createGroup3 "team" alice bob cath + threadDelay 1000000 + + bob `send` "#team @alice hi alice" + bob <# "#team @alice (direct) hi alice" + alice <# "#team bob (direct)> hi alice" + threadDelay 1000000 + + msgItemId1 <- lastItemId alice + alice ##> ("/_send #1 @2 json {\"filePath\": \"./tests/fixtures/test.pdf\", \"quotedItemId\": " <> msgItemId1 <> ", \"msgContent\": {\"text\":\"hey bob\",\"type\":\"file\"}}") + alice <# "#team @bob (direct) > bob hi alice" + alice <## " hey bob" + alice <# "/f #team @bob (direct) ./tests/fixtures/test.pdf" + alice <## "use /fc 1 to cancel sending" + bob <# "#team alice (direct)> > bob hi alice" + bob <## " hey bob" + bob <# "#team alice (direct)> sends file test.pdf (266.0 KiB / 272376 bytes)" + bob <## "use /fr 1 [/ | ] to receive it" + alice <## "completed uploading file 1 (test.pdf) for #team @bob (direct)" + + bob ##> "/fr 1 ./tests/tmp" + bob + <### [ "saving file 1 from alice to ./tests/tmp/test.pdf", + "started receiving file 1 (test.pdf) from alice" + ] + bob <## "completed receiving file 1 (test.pdf) from alice" + + src <- B.readFile "./tests/fixtures/test.pdf" + dest <- B.readFile "./tests/tmp/test.pdf" + dest `shouldBe` src + + cath "/fr 1 ./tests/tmp" + cath <##. "chat db error: SEUserNotFoundByFileId" + + alice + #$> ( "/_get chat #1 count=2", + chat''', + [ ((0, "bob", "hi alice"), Nothing, Nothing), + ((1, "bob", "hey bob"), Just (0, "direct", "hi alice"), Just "./tests/fixtures/test.pdf") + ] + ) + bob + #$> ( "/_get chat #1 count=2", + chat''', + [ ((1, "alice", "hi alice"), Nothing, Nothing), + ((0, "alice", "hey bob"), Just (1, "direct", "hi alice"), Just "./tests/tmp/test.pdf") + ] + ) + cath #$> ("/_get chat #1 count=1", chat''', [((0, "", "connected"), Nothing, Nothing)]) + where + cfg = testCfg {xftpFileConfig = Just $ XFTPFileConfig {minFileSize = 0}, tempDir = Just "./tests/tmp"} + +testGroupDirectUpdate :: HasCallStack => FilePath -> IO () +testGroupDirectUpdate = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice `send` "#team @bob hi bob" + alice <# "#team @bob (direct) hi bob" + bob <# "#team alice (direct)> hi bob" + + msgItemId1 <- lastItemId alice + alice ##> ("/_update item #1 " <> msgItemId1 <> " text hey 👋") + alice <# "#team @bob (direct) [edited] hey 👋" + bob <# "#team alice (direct)> [edited] hey 👋" + cath "! #team (hey 👋) hello there" + alice <# "#team @bob (direct) [edited] hello there" + bob <# "#team alice (direct)> [edited] hello there" + cath FilePath -> IO () +testGroupDirectDelete = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice `send` "#team @bob hi bob" + alice <# "#team @bob (direct) hi bob" + bob <# "#team alice (direct)> hi bob" + + msgItemId1 <- lastItemId alice + alice #$> ("/_delete item #1 " <> msgItemId1 <> " broadcast", id, "message marked deleted") + bob <# "#team alice (direct)> [marked deleted] hi bob" + cath FilePath -> IO () +testGroupDirectLiveMessage = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice `send` "/live #team @bob hello" + msgItemId1 <- lastItemId alice + bob <#. "#team alice (direct)> [LIVE started]" + alice ##> ("/_update item #1 " <> msgItemId1 <> " text hello there") + alice <# "#team @bob (direct) [LIVE] hello there" + bob <# "#team alice (direct)> [LIVE ended] hello there" + cath FilePath -> IO () +testGroupDirectReactions = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3 "team" alice bob cath + + alice `send` "#team @bob hi bob" + alice <# "#team @bob (direct) hi bob" + bob <# "#team alice (direct)> hi bob" + + bob ##> "+1 #team hi" + bob <## "added 👍" + alice <# "#team bob (direct)> > alice hi bob" + alice <## " + 👍" + cath "+^ #team hi" + alice <## "added 🚀" + bob <# "#team alice (direct)> > alice hi bob" + bob <## " + 🚀" + cath FilePath -> IO () +testGroupDirectProhibitPreference = + testChat3 aliceProfile bobProfile cathProfile $ \alice bob cath -> do + createGroup3' "team" alice bob cath GRMember + + alice ##> "/set direct #team off" + alice <## "updated group preferences:" + alice <## "Direct messages: off" + directProhibited bob + directProhibited cath + + bob ##> "#team @cath hi cath" + bob <## "bad chat command: direct messages not allowed" + + cath ##> "#team @bob hi cath" + cath <## "bad chat command: direct messages not allowed" + + alice ##> "/mr team bob admin" + alice <## "#team: you changed the role of bob from member to admin" + concurrentlyN_ + [ bob <## "#team: alice changed your role from member to admin", + cath <## "#team: alice changed the role of bob from member to admin" + ] + + -- admin can send & can send to admin + + bob `send` "#team @cath hi cath, as admin" + bob <# "#team @cath (direct) hi cath, as admin" + cath <# "#team bob (direct)> hi cath, as admin" + + cath `send` "#team @bob hi bob, to admin" + cath <# "#team @bob (direct) hi bob, to admin" + bob <# "#team cath (direct)> hi bob, to admin" + where + directProhibited :: HasCallStack => TestCC -> IO () + directProhibited cc = do + cc <## "alice updated group #team:" + cc <## "updated group preferences:" + cc <## "Direct messages: off" + +testGroupDirectProhibitNotSupported :: HasCallStack => FilePath -> IO () +testGroupDirectProhibitNotSupported tmp = + withNewTestChat tmp "alice" aliceProfile $ \alice -> do + withNewTestChat tmp "bob" bobProfile $ \bob -> do + withNewTestChatCfg tmp testCfg {chatVRange = mkVersionRange 1 1} "cath" cathProfile $ \cath -> do + createGroup3 "team" alice bob cath + + bob ##> "#team @cath hi cath" + bob <## "peer chat protocol version range incompatible" diff --git a/tests/ChatTests/Utils.hs b/tests/ChatTests/Utils.hs index c120d661f..05075f5b5 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -181,7 +181,12 @@ chatF :: String -> [((Int, String), Maybe String)] chatF = map (\(a, _, c) -> (a, c)) . chat'' chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)] -chat'' = read +chat'' = map (\(a, b, c) -> (mapNoDirect a, mapNoDirect <$> b, c)) . chat''' + where + mapNoDirect (a1, _, a3) = (a1, a3) + +chat''' :: String -> [((Int, String, String), Maybe (Int, String, String), Maybe String)] +chat''' = read chatFeatures :: [(Int, String)] chatFeatures = map (\(a, _, _) -> a) chatFeatures'' @@ -456,27 +461,33 @@ showName (TestCC ChatController {currentUser} _ _ _ _ _) = do pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO () -createGroup2 gName cc1 cc2 = do +createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 GRAdmin + +createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO () +createGroup2' gName cc1 cc2 memberRole = do connectUsers cc1 cc2 name2 <- userName cc2 cc1 ##> ("/g " <> gName) cc1 <## ("group #" <> gName <> " is created") cc1 <## ("to add members use /a " <> gName <> " or /create link #" <> gName) - addMember gName cc1 cc2 GRAdmin + addMember gName cc1 cc2 memberRole cc2 ##> ("/j " <> gName) concurrently_ (cc1 <## ("#" <> gName <> ": " <> name2 <> " joined the group")) (cc2 <## ("#" <> gName <> ": you joined the group")) createGroup3 :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> IO () -createGroup3 gName cc1 cc2 cc3 = do - createGroup2 gName cc1 cc2 +createGroup3 gName cc1 cc2 cc3 = createGroup3' gName cc1 cc2 cc3 GRAdmin + +createGroup3' :: HasCallStack => String -> TestCC -> TestCC -> TestCC -> GroupMemberRole -> IO () +createGroup3' gName cc1 cc2 cc3 memberRole = do + createGroup2' gName cc1 cc2 memberRole connectUsers cc1 cc3 name1 <- userName cc1 name3 <- userName cc3 sName2 <- showName cc2 sName3 <- showName cc3 - addMember gName cc1 cc3 GRAdmin + addMember gName cc1 cc3 memberRole cc3 ##> ("/j " <> gName) concurrentlyN_ [ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"), diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 3acc78e7d..f9421f691 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -57,7 +57,7 @@ testConnReq = CRInvitationUri connReqData testE2ERatchetParams quotedMsg :: QuotedMsg quotedMsg = QuotedMsg - (MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing) + (MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing Nothing) $ MCText "hello there!" (==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation @@ -105,10 +105,13 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") Nothing)) it "x.msg.new simple text - timed message TTL" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"ttl\":3600}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing)) it "x.msg.new simple text - live message" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"live\":true}}" - #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing)) + it "x.msg.new simple text - direct message scope" $ + "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"scope\":\"direct\"}}" + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing Nothing (Just MSDirect))) it "x.msg.new simple link" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"https://simplex.chat\",\"type\":\"link\",\"preview\":{\"description\":\"SimpleX Chat\",\"image\":\"data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA\",\"title\":\"SimpleX Chat\",\"uri\":\"https://simplex.chat\"}}}}" #==# XMsgNew (MCSimple (extMsgContent (MCLink "https://simplex.chat" $ LinkPreview {uri = "https://simplex.chat", title = "SimpleX Chat", description = "SimpleX Chat", image = ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgA", content = Nothing}) Nothing)) @@ -130,27 +133,41 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew (MCQuote quotedMsg (extMsgContent (MCText "hello to you too") Nothing))) + it "x.msg.new quote - direct referenced message scope" $ + "{\"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\",\"msgScope\":\"direct\"}}}}" + ##==## ChatMessage + chatInitialVRange + (Just $ SharedMsgId "\1\2\3\4") + ( XMsgNew + ( MCQuote + ( QuotedMsg + (MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing (Just MSDirect)) + $ MCText "hello there!" + ) + (extMsgContent (MCText "hello to you too") Nothing) + ) + ) it "x.msg.new quote - timed message TTL" $ "{\"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\"}},\"ttl\":3600}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) Nothing Nothing))) it "x.msg.new quote - live message" $ "{\"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\"}},\"live\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") - (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True) Nothing))) it "x.msg.new forward" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true}}" ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (extMsgContent (MCText "hello") Nothing)) it "x.msg.new forward - timed message TTL" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"ttl\":3600}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) Nothing Nothing)) it "x.msg.new forward - live message" $ "{\"v\":\"1\",\"msgId\":\"AQIDBA==\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"forward\":true,\"live\":true}}" - ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True) Nothing)) it "x.msg.new simple text with file" $ "{\"v\":\"1\",\"event\":\"x.msg.new\",\"params\":{\"content\":{\"text\":\"hello\",\"type\":\"text\"},\"file\":{\"fileSize\":12345,\"fileName\":\"photo.jpg\"}}}" #==# XMsgNew (MCSimple (extMsgContent (MCText "hello") (Just FileInvitation {fileName = "photo.jpg", fileSize = 12345, fileDigest = Nothing, fileConnReq = Nothing, fileInline = Nothing, fileDescr = Nothing})))