diff --git a/simplex-chat.cabal b/simplex-chat.cabal index 35e01e7bc..ebd3d1d64 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -111,7 +111,6 @@ 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 9522d2218..49c5fc94e 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 sendRef live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case sendRef of - SRDirect chatId -> do + APISendMessage (ChatRef cType chatId) live itemTTL (ComposedMessage file_ quotedItemId_ mc) -> withUser $ \user@User {userId} -> withChatLock "sendMessage" $ case cType of + CTDirect -> 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 $ SDDirect ct + SendFileXFTP -> xftpSndFileTransfer user file fileSize 1 $ CGContact 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,38 +590,36 @@ 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) + Nothing -> pure (MCSimple (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), 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, msgScope = Nothing} + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = 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) Nothing), Just quotedItem) + pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fInv_ (ttl' <$> timed_) (justTrue live)), 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 - 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 + CTGroup -> do + g@(Group gInfo _) <- withStore $ \db -> getGroup db user chatId + assertUserGroupRole gInfo GRAuthor + send g where - send gInfo@GroupInfo {groupId, membership, localDisplayName = gName} directMember + send g@(Group gInfo@GroupInfo {groupId, membership, localDisplayName = gName} ms) | isVoice mc && not (groupFeatureAllowed SGFVoice gInfo) = notAllowedError GFVoice | not (isVoice mc) && isJust file_ && not (groupFeatureAllowed SGFFiles gInfo) = notAllowedError GFFiles | otherwise = do - ms <- getReceivingMembers user gInfo directMember - (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer gInfo ms (length ms) + (fInv_, ciFile_, ft_) <- unzipMaybe3 <$> setupSndFileTransfer g (length $ filter memberCurrent ms) timed_ <- sndGroupCITimed live gInfo itemTTL - (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership directMember + (msgContainer, quotedItem_) <- prepareMsg fInv_ timed_ membership (msg@SndMessage {sharedMsgId}, sentToMembers) <- sendGroupMessage user gInfo ms (XMsgNew msgContainer) mapM_ (sendGroupFileInline ms sharedMsgId) ft_ - ci <- saveSndChatItem' user (CDGroupSnd gInfo directMember) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live + ci <- saveSndChatItem' user (CDGroupSnd gInfo) msg (CISndMsgContent mc) ciFile_ quotedItem_ timed_ live withStore' $ \db -> forM_ sentToMembers $ \GroupMember {groupMemberId} -> createGroupSndStatus db (chatItemId' ci) groupMemberId CISSndNew @@ -630,12 +628,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 :: GroupInfo -> [GroupMember] -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta)) - setupSndFileTransfer gInfo ms n = forM file_ $ \file -> do + setupSndFileTransfer :: Group -> Int -> m (Maybe (FileInvitation, CIFile 'MDSnd, FileTransferMeta)) + setupSndFileTransfer g@(Group gInfo _) 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 $ SDGroup gInfo ms + SendFileXFTP -> xftpSndFileTransfer user file fileSize n $ CGGroup g 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 @@ -659,44 +657,25 @@ processChatCommand = \case void . withStore' $ \db -> createSndGroupInlineFT db m conn ft sendMemberFileInline m conn ft sharedMsgId processMember _ = pure () - 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) + 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) Just quotedItemId -> do - CChatItem _ qci@ChatItem {chatDir = quoteChatDir, meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- + CChatItem _ qci@ChatItem {meta = CIMeta {itemTs, itemSharedMsgId}, formattedText, file} <- withStore $ \db -> getGroupChatItem db user chatId quotedItemId - 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} + (origQmc, qd, sent, GroupMember {memberId}) <- quoteData qci membership + let msgRef = MsgRef {msgId = itemSharedMsgId, sentAt = itemTs, sent, memberId = Just memberId} qmc = quoteContent origQmc file - 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) + 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) where - 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 + 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" where quoteContent :: forall d. MsgContent -> Maybe (CIFile d) -> MsgContent quoteContent qmc ciFile_ @@ -721,8 +700,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 -> SendDirection -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) - xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n sendDirection = do + xftpSndFileTransfer :: User -> CryptoFile -> Integer -> Int -> ContactOrGroup -> m (FileInvitation, CIFile 'MDSnd, FileTransferMeta) + xftpSndFileTransfer user file@(CryptoFile filePath cfArgs) fileSize n contactOrGroup = do let fileName = takeFileName filePath fileDescr = FileDescr {fileDescrText = "", fileDescrPartNo = 0, fileDescrComplete = False} fInv = xftpFileInvitation fileName fileSize fileDescr @@ -731,20 +710,19 @@ 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 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)) + 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 () 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) @@ -772,28 +750,28 @@ processChatCommand = \case _ -> throwChatError CEInvalidChatItemUpdate CChatItem SMDRcv _ -> throwChatError CEInvalidChatItemUpdate CTGroup -> do - 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 + 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 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 @@ -810,25 +788,22 @@ processChatCommand = \case else markDirectCIDeleted user ct ci msgId True =<< liftIO getCurrentTime (CIDMBroadcast, _, _, _) -> throwChatError CEInvalidChatItemDelete CTGroup -> do - 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 + 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 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} MSGroup, Just itemSharedMId) -> do + (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete assertUserGroupRole gInfo $ max GRAdmin memberRole (SndMessage {msgId}, _) <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId @@ -854,15 +829,13 @@ processChatCommand = \case pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTGroup -> - 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 + 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 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) @@ -871,7 +844,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 directMember) ci' createdAt reaction + r = ACIReaction SCTGroup SMDSnd (GroupChat g) $ CIReaction CIGroupSnd ci' createdAt reaction pure $ CRChatItemReaction user add r _ -> throwChatError $ CECommandError "reaction not possible - no shared item ID" CTContactRequest -> pure $ chatCmdError (Just user) "not supported" @@ -1235,7 +1208,7 @@ processChatCommand = \case case memberConnId m of Just connId -> do cStats@ConnectionStats {ratchetSyncState = rss} <- withAgent $ \a -> synchronizeRatchet a connId force - createInternalChatItem user (CDGroupSnd g Nothing) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing + createInternalChatItem user (CDGroupSnd g) (CISndConnEvent . SCERatchetSync rss . Just $ groupMemberRef m) Nothing pure $ CRGroupMemberRatchetSyncStarted user g m cStats _ -> throwChatError CEGroupMemberNotActive APIGetContactCode contactId -> withUser $ \user -> do @@ -1395,8 +1368,8 @@ processChatCommand = \case RejectContact cName -> withUser $ \User {userId} -> do connReqId <- withStore $ \db -> getContactRequestIdByName db userId cName processChatCommand $ APIRejectContact connReqId - SendMessage sendName msg -> sendTextMessage sendName msg False - SendLiveMessage sendName msg -> sendTextMessage sendName msg True + SendMessage chatName msg -> sendTextMessage chatName msg False + SendLiveMessage chatName msg -> sendTextMessage chatName msg True SendMessageBroadcast msg -> withUser $ \user -> do contacts <- withStore' (`getUserContacts` user) let cts = filter (\ct -> isReady ct && directOrUsed ct) contacts @@ -1416,7 +1389,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 (SRDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + processChatCommand . APISendMessage (ChatRef CTDirect contactId) False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc DeleteMessage chatName deletedMsg -> withUser $ \user -> do chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg @@ -1430,10 +1403,10 @@ processChatCommand = \case editedItemId <- getSentChatItemIdByText user chatRef editedMsg let mc = MCText msg processChatCommand $ APIUpdateChatItem chatRef editedItemId False mc - UpdateLiveMessage sendName chatItemId live msg -> withUser $ \user -> do - sendRef <- getSendRef user sendName + UpdateLiveMessage chatName chatItemId live msg -> withUser $ \user -> do + chatRef <- getChatRef user chatName let mc = MCText msg - processChatCommand $ APIUpdateChatItem (sendToChatRef sendRef) chatItemId live mc + processChatCommand $ APIUpdateChatItem chatRef chatItemId live mc ReactToMessage add reaction chatName msg -> withUser $ \user -> do chatRef <- getChatRef user chatName chatItemId <- getChatItemIdByText user chatRef msg @@ -1518,7 +1491,7 @@ processChatCommand = \case _ -> throwChatError $ CEGroupCantResendInvitation gInfo cName _ -> do (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemRole mId memRole - ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent gEvent) + ci <- saveSndChatItem user (CDGroupSnd gInfo) 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 @@ -1534,7 +1507,7 @@ processChatCommand = \case withStore' $ \db -> deleteGroupMember db user m _ -> do (msg, _) <- sendGroupMessage user gInfo members $ XGrpMemDel mId - ci <- saveSndChatItem user (CDGroupSnd gInfo Nothing) msg (CISndGroupEvent $ SGEMemberDeleted memberId (fromLocalProfile memberProfile)) + ci <- saveSndChatItem user (CDGroupSnd gInfo) 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 @@ -1544,7 +1517,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 Nothing) msg (CISndGroupEvent SGEUserLeft) + ci <- saveSndChatItem user (CDGroupSnd gInfo) msg (CISndGroupEvent SGEUserLeft) toView $ CRNewChatItem user (AChatItem SCTGroup SMDSnd (GroupChat gInfo) ci) -- TODO delete direct connections that were unused deleteGroupLinkIfExists user gInfo @@ -1627,13 +1600,11 @@ processChatCommand = \case ShowGroupLink gName -> withUser $ \user -> do groupId <- withStore $ \db -> getGroupIdByName db user gName processChatCommand $ APIGetGroupLink groupId - SendGroupMessageQuote gName cName directMemberName quotedMsg msg -> withUser $ \user -> do + SendGroupMessageQuote gName cName 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 sendRef = SRGroup groupId directMemberId - mc = MCText msg - processChatCommand . APISendMessage sendRef False Nothing $ ComposedMessage Nothing (Just quotedItemId) mc + let mc = MCText msg + processChatCommand . APISendMessage (ChatRef CTGroup groupId) 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 @@ -1666,19 +1637,19 @@ processChatCommand = \case processChatCommand $ APIGetChatItemInfo chatRef itemId ShowLiveItems on -> withUser $ \_ -> asks showLiveItems >>= atomically . (`writeTVar` on) >> ok_ - 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 + 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 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 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 + 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 SendFileDescription _chatName _f -> pure $ chatCmdError Nothing "TODO" ReceiveFile fileId encrypted rcvInline_ filePath_ -> withUser $ \_ -> withChatLock "receiveFile" . procCmd $ do @@ -1702,7 +1673,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 -> + CancelFile fileId -> withUser $ \user@User {userId} -> withChatLock "cancelFile" . procCmd $ withStore (\db -> getFileTransfer db user fileId) >>= \case FTSnd ftm@FileTransferMeta {xftpSndFile, cancelled} fts @@ -1712,22 +1683,20 @@ processChatCommand = \case | otherwise -> do fileAgentConnIds <- cancelSndFile user ftm fts True deleteAgentConnectionsAsync user fileAgentConnIds - sendXFileCancel - ci' <- withStore $ \db -> getChatItemByFileId db user fileId - pure $ CRSndFileCancelled user ci' ftm fts + 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 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" @@ -1842,15 +1811,6 @@ 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 () @@ -1983,29 +1943,15 @@ processChatCommand = \case assertUserGroupRole g GROwner g' <- withStore $ \db -> updateGroupProfile db user g p' (msg, _) <- sendGroupMessage user g' ms (XGrpInfo p') - let cd = CDGroupSnd g' Nothing + let cd = CDGroupSnd g' 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 @@ -2050,14 +1996,14 @@ processChatCommand = \case withServerProtocol p action = case userProtocol p of Just Dict -> action _ -> throwChatError $ CEServerProtocol $ AProtocolType p - forwardFile :: SendName -> FileTransferId -> (SendName -> FilePath -> ChatCommand) -> m ChatResponse - forwardFile sendName fileId sendCommand = withUser $ \user -> do + forwardFile :: ChatName -> FileTransferId -> (ChatName -> FilePath -> ChatCommand) -> m ChatResponse + forwardFile chatName 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 sendName + forward = processChatCommand . sendCommand chatName getGroupAndMemberId :: User -> GroupName -> ContactName -> m (GroupId, GroupMemberId) getGroupAndMemberId user gName groupMemberName = withStore $ \db -> do @@ -2073,10 +2019,10 @@ processChatCommand = \case ci <- saveSndChatItem user (CDDirectSnd ct) msg content toView $ CRNewChatItem user (AChatItem SCTDirect SMDSnd (DirectChat ct) ci) setActive $ ActiveG localDisplayName - sendTextMessage sendName msg live = withUser $ \user -> do - sendRef <- getSendRef user sendName + sendTextMessage chatName msg live = withUser $ \user -> do + chatRef <- getChatRef user chatName let mc = MCText msg - processChatCommand . APISendMessage sendRef live Nothing $ ComposedMessage Nothing Nothing mc + processChatCommand . APISendMessage chatRef 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) @@ -2148,26 +2094,6 @@ 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 $ @@ -2386,7 +2312,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 = do +receiveViaCompleteFD user fileId RcvFileDescr {fileDescrText, fileDescrComplete} cfArgs = when fileDescrComplete $ do rd <- parseFileDescription fileDescrText aFileId <- withAgent $ \a -> xftpReceiveFile a (aUserId user) rd cfArgs @@ -2823,46 +2749,45 @@ processAgentMsgSndFile _corrId aFileId msg = toView $ CRSndFileProgressXFTP user ci ft sndProgress sndTotal SFDONE sndDescr rfds -> do withStore' $ \db -> setSndFTPrivateSndDescr db user fileId (fileDescrText sndDescr) - 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 + 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 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 @@ -3198,7 +3123,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 MSGroup) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEInvitedViaGroupLink) Nothing _ -> throwChatError $ CECommandError "unexpected cmdFunction" CRContactUri _ -> throwChatError $ CECommandError "unexpected ConnectionRequestUri type" CONF confId _ connInfo -> do @@ -3287,10 +3212,10 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do let m' = m {activeConn = Just conn'} :: GroupMember updateChatLock "groupMessage" event case event of - XMsgNew mc -> newGroupContentMessage gInfo m' mc msg msgMeta - XMsgFileDescr sharedMsgId fileDescr -> groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta + XMsgNew mc -> canSend m' $ newGroupContentMessage gInfo m' mc msg msgMeta + XMsgFileDescr sharedMsgId fileDescr -> canSend m' $ groupMessageFileDescription gInfo m' sharedMsgId fileDescr msgMeta XMsgFileCancel sharedMsgId -> cancelGroupMessageFile gInfo m' sharedMsgId msgMeta - XMsgUpdate sharedMsgId mContent ttl live -> groupMessageUpdate gInfo m' sharedMsgId mContent msg msgMeta ttl live + XMsgUpdate sharedMsgId mContent ttl live -> canSend m' $ 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 @@ -3314,6 +3239,10 @@ 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 @@ -3324,8 +3253,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 Nothing) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing - QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing + QDRcv -> createInternalChatItem user (CDGroupSnd gInfo) (CISndConnEvent . SCESwitchQueue phase . Just $ groupMemberRef m) Nothing + QDSnd -> createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvConnEvent $ RCESwitchQueue phase) Nothing RSYNC rss cryptoErr_ cStats -> case (rss, connectionCode, cryptoErr_) of (RSRequired, _, Just cryptoErr) -> processErr cryptoErr @@ -3335,7 +3264,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' MSGroup) (CIRcvConnEvent RCEVerificationCodeReset) Nothing + createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent RCEVerificationCodeReset) Nothing _ -> ratchetSyncEventItem m where processErr cryptoErr = do @@ -3349,10 +3278,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 MSGroup) (CIRcvDecryptionError mde n) Nothing + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvDecryptionError mde n) Nothing ratchetSyncEventItem m' = do toView $ CRGroupMemberRatchetSync user gInfo m' (RatchetSyncProgress rss cStats) - createInternalChatItem user (CDGroupRcv gInfo m' MSGroup) (CIRcvConnEvent $ RCERatchetSync rss) Nothing + createInternalChatItem user (CDGroupRcv gInfo m') (CIRcvConnEvent $ RCERatchetSync rss) Nothing OK -> -- [async agent commands] continuation on receiving OK withCompletedCommand conn agentMsg $ \CommandData {cmdFunction, cmdId} -> @@ -3649,11 +3578,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 MSGroup) (CIRcvGroupEvent RGEMemberConnected) Nothing + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> m () groupDescriptionChatItem gInfo m descr = - createInternalChatItem user (CDGroupRcv gInfo m MSGroup) (CIRcvMsgContent $ MCText descr) Nothing + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing notifyMemberConnected :: GroupInfo -> GroupMember -> Maybe Contact -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} ct_ = do @@ -3691,7 +3620,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" -> @@ -3703,7 +3632,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 @@ -3731,16 +3660,9 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do processFDMessage fileId fileDescr groupMessageFileDescription :: GroupInfo -> GroupMember -> SharedMsgId -> FileDescr -> MsgMeta -> m () - 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" + groupMessageFileDescription GroupInfo {groupId} _m sharedMsgId fileDescr _msgMeta = do + fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId + processFDMessage fileId fileDescr processFDMessage :: FileTransferId -> FileDescr -> m () processFDMessage fileId fileDescr = do @@ -3861,14 +3783,13 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do where updateChatItemReaction = do cr_ <- withStore $ \db -> do - CChatItem md ci@ChatItem {chatDir} <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId - if directMemberCIUpdateAllowed ci m && ciReactionAllowed ci + CChatItem md ci <- getGroupMemberCIBySharedMsgId db user groupId itemMemberId sharedMsgId + if ciReactionAllowed ci then liftIO $ do setGroupReaction db g m itemMemberId sharedMsgId False reaction add msgId brokerTs reactions <- getGroupCIReactions db g itemMemberId sharedMsgId let ci' = CChatItem md ci {reactions} - msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir - r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m msgScope) ci' brokerTs reaction + r = ACIReaction SCTGroup SMDRcv (GroupChat g) $ CIReaction (CIGroupRcv m) ci' brokerTs reaction pure $ Just $ CRChatItemReaction user add r else pure Nothing mapM_ toView cr_ @@ -3876,12 +3797,6 @@ 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 @@ -3889,41 +3804,32 @@ 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 = do - assertMemberSendAllowed gInfo m msgScope $ rejected GFDirectMessages >> directMsgProhibitedErr - processMessage + 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 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_ msgScope_ = mcExtMsgContent mc - msgScope = fromMaybe MSGroup msgScope_ + ExtMsgContent content fInv_ itemTTL live_ = mcExtMsgContent mc 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 MSGroup) msg sharedMsgId_ msgMeta CIRcvModerated Nothing timed_ False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) 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 MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent content) (snd <$> file_) timed_ False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) 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 @@ -3935,39 +3841,24 @@ 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 msgScope) msg sharedMsgId_ msgMeta ciContent ciFile_ timed_ live + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) 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} GroupMember {groupMemberId, memberId} sharedMsgId mc RcvMessage {msgId} msgMeta _ttl_ live_ = - updateRcvChatItem `catchCINotFound` \_ -> - withStore' (`deleteMessage` msgId) + 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 where MsgMeta {broker = (_, brokerTs)} = msgMeta content = CIRcvMsgContent mc @@ -3975,10 +3866,9 @@ 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' msgScope, meta = CIMeta {itemLive}, content = CIRcvMsgContent oldMC} -> + CChatItem SMDRcv ci@ChatItem {chatDir = CIGroupRcv m', 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 @@ -3998,13 +3888,10 @@ 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 msgScope + CIGroupRcv mem | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView - | 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" + | otherwise -> deleteMsg mem ci + CIGroupSnd -> deleteMsg membership ci 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 @@ -4047,7 +3934,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 MSGroup) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False + ci <- saveRcvChatItem' user (CDGroupRcv gInfo m) msg sharedMsgId_ msgMeta (CIRcvMsgContent $ MCFile "") ciFile Nothing False groupMsgToView gInfo m ci msgMeta let g = groupName' gInfo whenGroupNtfs user gInfo $ do @@ -4156,11 +4043,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 MSGroup) msgMeta + checkIntegrityCreateItem (CDGroupRcv g mem) 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) @@ -4173,7 +4060,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 MSGroup) msgMeta + checkIntegrityCreateItem (CDGroupRcv g m) msgMeta fileId <- withStore $ \db -> getGroupFileIdBySharedMsgId db userId groupId sharedMsgId (AChatItem _ _ _ ci) <- withStore $ \db -> getChatItemByFileId db user fileId assertSMPAcceptNotProhibited ci @@ -4204,7 +4091,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 MSGroup) msgMeta + checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta toView $ CRNewChatItem user (AChatItem SCTGroup SMDRcv (GroupChat gInfo) ci) processGroupInvitation :: Contact -> GroupInvitation -> RcvMessage -> MsgMeta -> m () @@ -4280,7 +4167,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 MSGroup) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing + createInternalChatItem user (CDGroupRcv g m) (CIRcvGroupFeature (toGroupFeature f) (toGroupPreference p) param) Nothing xInfoProbe :: Contact -> Probe -> m () xInfoProbe c2 probe = @@ -4443,7 +4330,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 MSGroup) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent $ RGEMemberAdded groupMemberId memberProfile) groupMsgToView gInfo m ci msgMeta toView $ CRJoinedGroupMemberConnecting user gInfo m newMember @@ -4527,7 +4414,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 MSGroup) msg msgMeta (CIRcvGroupEvent gEvent) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) groupMsgToView gInfo m ci msgMeta toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole} @@ -4562,7 +4449,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 MSGroup) msg msgMeta (CIRcvGroupEvent gEvent) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent gEvent) groupMsgToView gInfo m ci msgMeta sameMemberId :: MemberId -> GroupMember -> Bool @@ -4573,7 +4460,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 MSGroup) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEMemberLeft) groupMsgToView gInfo m ci msgMeta toView $ CRLeftMember user gInfo m {memberStatus = GSMemLeft} @@ -4586,7 +4473,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 MSGroup) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted) + ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg msgMeta (CIRcvGroupEvent RGEGroupDeleted) groupMsgToView gInfo m ci msgMeta toView $ CRGroupDeleted user gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m @@ -4596,7 +4483,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 MSGroup + let cd = CDGroupRcv g' m unless (sameGroupProfileInfo p p') $ do ci <- saveRcvChatItem user cd msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p') groupMsgToView g' m ci msgMeta @@ -4611,7 +4498,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 MSGroup) msgMeta + checkIntegrityCreateItem (CDGroupRcv gInfo m) msgMeta forM_ msgRcpts $ \MsgReceipt {agentMsgId, msgRcptStatus} -> do withStore $ \db -> createSndMsgDeliveryEvent db connId agentMsgId $ MDSSndRcvd msgRcptStatus updateGroupItemStatus gInfo m conn agentMsgId $ CISSndRcvd msgRcptStatus SSPComplete @@ -5324,7 +5211,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 <$> sendRefP <*> liveMessageP <*> sendMessageTTLP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))), + "/_send " *> (APISendMessage <$> chatRefP <*> 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), @@ -5448,7 +5335,8 @@ chatCommandP = "/set link role #" *> (GroupLinkMemberRole <$> displayName <*> memberRole), "/delete link #" *> (DeleteGroupLink <$> displayName), "/show link #" *> (ShowGroupLink <$> displayName), - (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <*> optional (" >@" *> displayName) <*> optional (" @" *> displayName) <* A.space <*> quotedMsg <*> msgTextP), + (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> msgTextP), + (">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* char_ '@' <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> msgTextP), "/_contacts " *> (APIListContacts <$> A.decimal), "/contacts" $> ListContacts, "/_connect " *> (APIConnect <$> A.decimal <*> incognitoOnOffP <* A.space <*> ((Just <$> strP) <|> A.takeByteString $> Nothing)), @@ -5456,8 +5344,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 <$> sendNameP <* A.space <*> msgTextP, - "/live " *> (SendLiveMessage <$> sendNameP <*> (A.space *> msgTextP <|> pure "")), + SendMessage <$> chatNameP <* A.space <*> msgTextP, + "/live " *> (SendLiveMessage <$> chatNameP <*> (A.space *> msgTextP <|> pure "")), (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> textP), @@ -5472,10 +5360,10 @@ chatCommandP = "/show" *> (ShowLiveItems <$> (A.space *> onOffP <|> pure True)), "/show " *> (ShowChatItem . Just <$> A.decimal), "/item info " *> (ShowChatItemInfo <$> chatNameP <* A.space <*> msgTextP), - ("/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), + ("/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), ("/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)), @@ -5586,13 +5474,6 @@ 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 50bddbb19..df9c66cee 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 (SRDirect ctId) False Nothing cm) >>= \case + sendChatCmd cc (APISendMessage (ChatRef CTDirect 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 26e4f4356..af9aa964c 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -34,7 +34,6 @@ 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) @@ -242,7 +241,7 @@ data ChatCommand | APIGetChat ChatRef ChatPagination (Maybe String) | APIGetChatItems ChatPagination (Maybe String) | APIGetChatItemInfo ChatRef ChatItemId - | APISendMessage {sendRef :: SendRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} + | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, ttl :: Maybe Int, composedMessage :: ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId @@ -353,14 +352,14 @@ data ChatCommand | AddressAutoAccept (Maybe AutoAccept) | AcceptContact IncognitoEnabled ContactName | RejectContact ContactName - | SendMessage SendName Text - | SendLiveMessage SendName Text + | SendMessage ChatName Text + | SendLiveMessage ChatName 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 {sendName :: SendName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text} + | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: Text} | ReactToMessage {add :: Bool, reaction :: MsgReaction, chatName :: ChatName, reactToMessage :: Text} | APINewGroup UserId GroupProfile | NewGroup GroupProfile @@ -382,17 +381,17 @@ data ChatCommand | GroupLinkMemberRole GroupName GroupMemberRole | DeleteGroupLink GroupName | ShowGroupLink GroupName - | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, directMemberName :: Maybe ContactName, quotedMsg :: Text, message :: Text} + | SendGroupMessageQuote {groupName :: GroupName, contactName_ :: 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 SendName FilePath - | SendImage SendName FilePath - | ForwardFile SendName FileTransferId - | ForwardImage SendName FileTransferId + | SendFile ChatName FilePath + | SendImage ChatName FilePath + | ForwardFile ChatName FileTransferId + | ForwardImage ChatName FileTransferId | SendFileDescription ChatName FilePath | ReceiveFile {fileId :: FileTransferId, storeEncrypted :: Bool, fileInline :: Maybe Bool, filePath :: Maybe FilePath} | SetFileToReceive {fileId :: FileTransferId, storeEncrypted :: Bool} @@ -613,37 +612,6 @@ 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) @@ -959,7 +927,6 @@ 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 f97a0dd1b..45e5f9ff7 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -50,6 +50,16 @@ 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) @@ -138,16 +148,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 :: Maybe GroupMember -> CIDirection 'CTGroup 'MDSnd - CIGroupRcv :: GroupMember -> MessageScope -> CIDirection 'CTGroup 'MDRcv + CIGroupSnd :: CIDirection 'CTGroup 'MDSnd + CIGroupRcv :: GroupMember -> CIDirection 'CTGroup 'MDRcv deriving instance Show (CIDirection c d) data JSONCIDirection = JCIDirectSnd | JCIDirectRcv - | JCIGroupSnd {directMember :: Maybe GroupMember} - | JCIGroupRcv {groupMember :: GroupMember, messageScope :: MessageScope} + | JCIGroupSnd + | JCIGroupRcv {groupMember :: GroupMember} deriving (Generic, Show) instance ToJSON JSONCIDirection where @@ -162,19 +172,8 @@ jsonCIDirection :: CIDirection c d -> JSONCIDirection jsonCIDirection = \case CIDirectSnd -> JCIDirectSnd CIDirectRcv -> JCIDirectRcv - 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 + CIGroupSnd -> JCIGroupSnd + CIGroupRcv m -> JCIGroupRcv m data CIReactionCount = CIReactionCount {reaction :: MsgReaction, userReacted :: Bool, totalReacted :: Int} deriving (Show, Generic) @@ -209,8 +208,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 @@ -239,22 +238,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 -> Maybe GroupMember -> ChatDirection 'CTGroup 'MDSnd - CDGroupRcv :: GroupInfo -> GroupMember -> MessageScope -> ChatDirection 'CTGroup 'MDRcv + CDGroupSnd :: GroupInfo -> ChatDirection 'CTGroup 'MDSnd + CDGroupRcv :: GroupInfo -> GroupMember -> ChatDirection 'CTGroup 'MDRcv toCIDirection :: ChatDirection c d -> CIDirection c d toCIDirection = \case CDDirectSnd _ -> CIDirectSnd CDDirectRcv _ -> CIDirectRcv - CDGroupSnd _ dm -> CIGroupSnd dm - CDGroupRcv _ m ms -> CIGroupRcv m ms + CDGroupSnd _ -> CIGroupSnd + CDGroupRcv _ m -> CIGroupRcv m 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, @@ -434,39 +433,29 @@ instance ToJSON (JSONCIReaction c d) where data CIQDirection (c :: ChatType) where CIQDirectSnd :: CIQDirection 'CTDirect CIQDirectRcv :: CIQDirection 'CTDirect - 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 + 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 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 -> JSONCIQDirection +jsonCIQDirection :: CIQDirection c -> Maybe JSONCIDirection jsonCIQDirection = \case - CIQDirectSnd -> JCIQDirectSnd - CIQDirectRcv -> JCIQDirectRcv - CIQGroupSnd ms -> JCIQGroupSnd ms - CIQGroupRcv m ms -> JCIQGroupRcv m ms + CIQDirectSnd -> Just JCIDirectSnd + CIQDirectRcv -> Just JCIDirectRcv + CIQGroupSnd -> Just JCIGroupSnd + CIQGroupRcv (Just m) -> Just $ JCIGroupRcv m + CIQGroupRcv Nothing -> Nothing 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 deleted file mode 100644 index 6c150b19c..000000000 --- a/src/Simplex/Chat/Migrations/M20230904_item_direct_group_member_id.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# 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 f9a9309db..c71cc9aa9 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -392,9 +392,7 @@ 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_direct_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL, - quoted_message_scope TEXT + item_deleted_ts TEXT ); CREATE TABLE chat_item_messages( chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, @@ -715,6 +713,3 @@ 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 b42ede41c..13692b57c 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, enumJSON, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) +import Simplex.Messaging.Parsers (dropPrefix, fromTextField_, fstToLower, parseAll, sumTypeJSON, taggedObjectJSON) import Simplex.Messaging.Util (eitherToMaybe, safeDecodeUtf8, (<$?>)) import Simplex.Messaging.Version hiding (version) @@ -58,10 +58,6 @@ 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} @@ -162,28 +158,11 @@ 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 - msgScope :: Maybe MessageScope + memberId :: Maybe MemberId -- must be present in all group message references, both referencing sent and received } deriving (Eq, Show, Generic) @@ -468,13 +447,7 @@ msgContentTag = \case MCFile {} -> MCFile_ MCUnknown {tag} -> MCUnknown_ tag -data ExtMsgContent = ExtMsgContent - { content :: MsgContent, - file :: Maybe FileInvitation, - ttl :: Maybe Int, - live :: Maybe Bool, - scope :: Maybe MessageScope - } +data ExtMsgContent = ExtMsgContent {content :: MsgContent, file :: Maybe FileInvitation, ttl :: Maybe Int, live :: Maybe Bool} deriving (Eq, Show) parseMsgContainer :: J.Object -> JT.Parser MsgContainer @@ -483,10 +456,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" <*> v .:? "scope" + mc = ExtMsgContent <$> v .: "content" <*> v .:? "file" <*> v .:? "ttl" <*> v .:? "live" extMsgContent :: MsgContent -> Maybe FileInvitation -> ExtMsgContent -extMsgContent mc file = ExtMsgContent mc file Nothing Nothing Nothing +extMsgContent mc file = ExtMsgContent mc file Nothing Nothing justTrue :: Bool -> Maybe Bool justTrue True = Just True @@ -530,7 +503,7 @@ msgContainerJSON = \case MCSimple mc -> o $ msgContent mc where o = JM.fromList - msgContent (ExtMsgContent c file ttl live scope) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) $ ("scope" .=? scope) ["content" .= c] + msgContent (ExtMsgContent c file ttl live) = ("file" .=? file) $ ("ttl" .=? ttl) $ ("live" .=? live) ["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 93b9ed612..ddd59319d 100644 --- a/src/Simplex/Chat/Store/Messages.hs +++ b/src/Simplex/Chat/Store/Messages.hs @@ -25,7 +25,6 @@ module Simplex.Chat.Store.Messages createRcvMsgDeliveryEvent, createPendingGroupMessage, getPendingGroupMessages, - deleteMessage, deletePendingGroupMessage, deleteOldMessages, updateChatTs, @@ -290,10 +289,6 @@ 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) @@ -302,7 +297,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, Maybe MessageScope) +type NewQuoteRow = (Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MemberId) updateChatTs :: DB.Connection -> User -> ChatDirection c d -> UTCTime -> IO () updateChatTs db User {userId} chatDirection chatTs = case toChatInfo chatDirection of @@ -325,15 +320,14 @@ 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, 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) + 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) 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 @@ -344,20 +338,19 @@ createNewRcvChatItem db user chatDirection RcvMessage {msgId, chatMsgEvent} shar quotedMsg = cmToQuotedMsg chatMsgEvent quoteRow :: NewQuoteRow quoteRow = case quotedMsg of - 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) + 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) 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, Nothing) + quoteRow = (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 @@ -366,12 +359,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, item_direct_group_member_id, + user_id, created_by_msg_id, contact_id, group_id, 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, quoted_message_scope - ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) + quoted_shared_msg_id, quoted_sent_at, quoted_content, quoted_sent, quoted_member_id + ) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] ((userId, msgId_) :. idsRow :. itemRow :. quoteRow) ciId <- insertedRowId db @@ -380,16 +373,12 @@ 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, Maybe Int64) + idsRow :: (Maybe Int64, Maybe Int64, Maybe Int64) idsRow = case chatDirection of - 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) + 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) ciTimedRow :: Maybe CITimed -> (Maybe Int, Maybe UTCTime) ciTimedRow (Just CITimed {ttl, deleteAt}) = (Just ttl, deleteAt) @@ -399,21 +388,19 @@ 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, msgScope}, content} = +getChatItemQuote_ db User {userId, userContactId} chatDirection QuotedMsg {msgRef = MsgRef {msgId, sentAt, sent, memberId}, content} = case chatDirection of CDDirectRcv Contact {contactId} -> getDirectChatItemQuote_ contactId (not sent) - CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} _directMember -> + CDGroupRcv GroupInfo {groupId, membership = GroupMember {memberId = userMemberId}} sender@GroupMember {memberId = senderMemberId} -> case memberId of Just mId - | mId == userMemberId -> (`ciQuote` CIQGroupSnd messageScope) <$> getUserGroupChatItemId_ groupId - | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender) messageScope) <$> getGroupChatItemId_ groupId mId + | mId == userMemberId -> (`ciQuote` CIQGroupSnd) <$> getUserGroupChatItemId_ groupId + | mId == senderMemberId -> (`ciQuote` CIQGroupRcv (Just sender)) <$> getGroupChatItemId_ groupId mId | otherwise -> getGroupChatItemQuote_ groupId mId - _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing messageScope + _ -> pure . ciQuote Nothing $ CIQGroupRcv Nothing 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 $ @@ -460,8 +447,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 messageScope - ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId $ CIQGroupRcv (Just $ toGroupMember userContactId memberRow) messageScope + ciQuoteGroup [] = ciQuote Nothing $ CIQGroupRcv Nothing + ciQuoteGroup ((Only itemId :. memberRow) : _) = ciQuote itemId . CIQGroupRcv . Just $ toGroupMember userContactId memberRow getChatPreviews :: DB.Connection -> User -> Bool -> IO [AChat] getChatPreviews db user withPCC = do @@ -569,7 +556,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, i.quoted_message_scope, + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, -- 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, @@ -577,11 +564,7 @@ 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, - -- 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 + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.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 @@ -607,8 +590,6 @@ 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 |] @@ -986,8 +967,10 @@ toDirectQuote :: QuoteRow -> Maybe (CIQuote 'CTDirect) toDirectQuote qr@(_, _, _, _, quotedSent) = toQuote qr $ direction <$> quotedSent where direction sent = if sent then CIQDirectSnd else CIQDirectRcv - toQuote (quotedItemId, quotedSharedMsgId, quotedSentAt, quotedMsgContent, _) dir = - CIQuote <$> dir <*> pure quotedItemId <*> pure quotedSharedMsgId <*> quotedSentAt <*> quotedMsgContent <*> (parseMaybeMarkdownList . msgContentText <$> quotedMsgContent) + +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) -- this function can be changed so it never fails, not only avoid failure on invalid json toDirectChatItem :: UTCTime -> ChatItemRow :. QuoteRow -> Either StoreError (CChatItem 'CTDirect) @@ -1030,60 +1013,37 @@ 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 = (Maybe ChatItemId, Maybe SharedMsgId, Maybe UTCTime, Maybe MsgContent, Maybe Bool, Maybe MessageScope) +type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow -type GroupQuoteMemberRow = GroupQuoteRow :. MaybeGroupMemberRow +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteMemberRow :. MaybeGroupMemberRow :. MaybeGroupMemberRow - -toGroupQuote :: GroupQuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) -toGroupQuote qr@(_, _, _, _, quotedSent, msgScope) quotedMember_ = - toQuote qr $ direction quotedSent quotedMember_ +toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) +toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ where - 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 (Just True) _ = Just CIQGroupSnd + direction (Just False) (Just member) = Just . CIQGroupRcv $ Just member + direction (Just False) Nothing = Just $ CIQGroupRcv Nothing 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 :. 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 +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 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 directMember_) ciStatus ciContent (maybeCIFile fileStatus) + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, 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 + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent Nothing (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv 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) + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent (maybeCIFile fileStatus) (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, 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 + Right $ cItem SMDRcv (CIGroupRcv member) 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 @@ -1108,8 +1068,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_ :. 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 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 _ _ _ = [] getAllChatItems :: DB.Connection -> User -> ChatPagination -> Maybe String -> ExceptT StoreError IO [AChatItem] @@ -1524,7 +1484,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, i.quoted_message_scope, + ri.chat_item_id, i.quoted_shared_msg_id, i.quoted_sent_at, i.quoted_content, i.quoted_sent, -- 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, @@ -1532,11 +1492,7 @@ 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, - -- 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 + dbp.display_name, dbp.full_name, dbp.image, dbp.contact_link, dbp.local_alias, dbp.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 @@ -1546,8 +1502,6 @@ 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 74e2d89d7..cbcc4ddd2 100644 --- a/src/Simplex/Chat/Store/Migrations.hs +++ b/src/Simplex/Chat/Store/Migrations.hs @@ -79,7 +79,6 @@ 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)] @@ -158,8 +157,7 @@ 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), - ("20230904_item_direct_group_member_id", m20230904_item_direct_group_member_id, Just down_m20230904_item_direct_group_member_id) + ("20230903_connections_to_subscribe", m20230903_connections_to_subscribe, Just down_m20230903_connections_to_subscribe) ] -- | 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 f28795a37..36cec49d7 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 sendName msg)) (CRNewChatItem _ (AChatItem cType SMDSnd _ ChatItem {meta = CIMeta {itemId}})) = do + startLiveMessage (Right (SendLiveMessage chatName 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 {sendName, chatItemId = itemId, livePrompt = True, sentMsg = s, typedMsg = s, liveThreadId, promptThreadId} + let lm = LiveMessage {chatName, 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 {sendName = n, livePrompt} = - "> " <> sendNameStr n <> " [" <> (if livePrompt then "LIVE" else " ") <> "] " + liveInputPrompt LiveMessage {chatName = n, livePrompt} = + "> " <> chatNameStr 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 {sendName, chatItemId} live = do - let cmd = UpdateLiveMessage sendName chatItemId live $ T.pack sentMsg +sendUpdatedLiveMessage cc sentMsg LiveMessage {chatName, chatItemId} live = do + let cmd = UpdateLiveMessage chatName 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 {sendName} + Just LiveMessage {chatName} | live -> do writeTVar termState ts' {previousInput} - writeTBQueue inputQ $ "/live " <> sendNameStr sendName + writeTBQueue inputQ $ "/live " <> chatNameStr chatName | otherwise -> writeTVar termState ts' {inputPrompt = "> ", previousInput} where - previousInput = sendNameStr sendName <> " " <> s + previousInput = chatNameStr chatName <> " " <> 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 1a3638028..ce68d715f 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 - { sendName :: SendName, + { chatName :: ChatName, chatItemId :: ChatItemId, livePrompt :: Bool, sentMsg :: String, diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index bcef3cbff..2d77cbe77 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 GroupInfo +data ContactOrGroup = CGContact Contact | CGGroup Group contactAndGroupIds :: ContactOrGroup -> (Maybe ContactId, Maybe GroupId) contactAndGroupIds = \case CGContact Contact {contactId} -> (Just contactId, Nothing) - CGGroup GroupInfo {groupId} -> (Nothing, Just groupId) + CGGroup (Group 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 4656ea5b2..1a740bef5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -322,35 +322,14 @@ responseToView user_ ChatConfig {logLevel, showReactions, showReceipts, testView testViewChat :: AChat -> [StyledString] testViewChat (AChat _ Chat {chatInfo, chatItems}) = [sShow $ map toChatView chatItems] where - toChatView :: CChatItem c -> ((Int, String, Text), Maybe (Int, String, Text), Maybe String) - toChatView ci@(CChatItem dir ChatItem {chatDir, quotedItem, file}) = - (item, qItem, fPath) + 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) 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, - 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" + Just (msgDirectionInt $ quoteMsgDirection quoteDir, msgContentText content) fPath = case file of Just CIFile {fileSource = Just (CryptoFile fp _)} -> Just fp _ -> Nothing @@ -401,7 +380,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] @@ -424,9 +403,8 @@ 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 = @@ -448,20 +426,20 @@ viewChatItem chat ci@ChatItem {chatDir, meta = meta, content, quotedItem, file} where quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of - CIGroupSnd directMember -> case content of + CIGroupSnd -> case content of CISndMsgContent mc -> hideLive meta $ withSndFile to $ sndMsg to quote mc CISndGroupInvitation {} -> showSndItemProhibited to _ -> showSndItem to where - to = ttyToGroup g directMember - CIGroupRcv m msgScope -> case content of + to = ttyToGroup g + CIGroupRcv m -> 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 msgScope) quote meta [plainContent content] False + CIRcvModerated {} -> receivedWithTime_ ts tz (ttyFromGroup g m) quote meta [plainContent content] False _ -> showRcvItem from where - from = ttyFromGroup g m msgScope + from = ttyFromGroup g m where quote = maybe [] (groupQuote g) quotedItem _ -> [] @@ -553,18 +531,18 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive} where quote = maybe [] (directQuote chatDir) quotedItem GroupChat g -> case chatDir of - CIGroupRcv m msgScope -> case content of + CIGroupRcv m -> 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 msgScope else ttyFromGroup g m msgScope - CIGroupSnd directMember -> case content of + from = if itemEdited then ttyFromGroupEdited g m else ttyFromGroup g m + CIGroupSnd -> case content of CISndMsgContent mc -> hideLive meta $ viewSentMessage to quote mc ts tz meta _ -> [] where - to = if itemEdited then ttyToGroupEdited g directMember else ttyToGroup g directMember + to = if itemEdited then ttyToGroupEdited g else ttyToGroup g where quote = maybe [] (groupQuote g) quotedItem _ -> [] @@ -589,8 +567,7 @@ viewItemDelete chat ci@ChatItem {chatDir, meta, content = deletedContent} toItem GroupChat g -> case ciMsgContent deletedContent of Just mc -> let m = chatItemMember g ci - msgScope = directMemberToMsgScope $ ciDirDirectMember chatDir - in viewReceivedMessage (ttyFromGroupDeleted g m msgScope deletedText_) [] mc ts tz meta + in viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts tz meta _ -> prohibited _ -> prohibited where @@ -609,14 +586,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 messageScope) -> case ciMsgContent content of + (GroupChat g, CIGroupRcv m) -> case ciMsgContent content of Just mc -> view from $ reactionMsg mc _ -> [] where - from = ttyFromGroup g m messageScope + from = ttyFromGroup g m 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 @@ -644,13 +621,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 @@ -1342,9 +1319,8 @@ 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 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 (AChatItem _ _ (GroupChat g) ChatItem {file = Just CIFile {fileId, fileName}, chatDir = CIGroupSnd}) = + [status <> " uploading " <> fileTransferStr fileId fileName <> " for " <> ttyGroup' g] uploadingFile status _ = [status <> " uploading file"] -- shouldn't happen sndFile :: SndFileTransfer -> StyledString @@ -1376,7 +1352,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 @@ -1390,7 +1366,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 @@ -1606,7 +1582,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 -> ["invalid message reply"] + CEInvalidQuote -> ["cannot reply to this message"] CEInvalidChatItemUpdate -> ["cannot update this item"] CEInvalidChatItemDelete -> ["cannot delete this item"] CEHasCurrentCall -> ["call already in progress"] @@ -1621,7 +1597,6 @@ 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] @@ -1762,24 +1737,19 @@ ttyFullGroup :: GroupInfo -> StyledString ttyFullGroup GroupInfo {localDisplayName = g, groupProfile = GroupProfile {fullName}} = ttyGroup g <> optFullName g fullName -ttyFromGroup :: GroupInfo -> GroupMember -> MessageScope -> StyledString -ttyFromGroup g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms) +ttyFromGroup :: GroupInfo -> GroupMember -> StyledString +ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m) -ttyFromGroupEdited :: GroupInfo -> GroupMember -> MessageScope -> StyledString -ttyFromGroupEdited g m ms = membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> "[edited] ") +ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString +ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") -ttyFromGroupDeleted :: GroupInfo -> GroupMember -> MessageScope -> Maybe Text -> StyledString -ttyFromGroupDeleted g m ms deletedText_ = - membershipIncognito g <> ttyFrom (fromGroup_ g m ms <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) +ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString +ttyFromGroupDeleted g m deletedText_ = + membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) -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)" +fromGroup_ :: GroupInfo -> GroupMember -> Text +fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = + "#" <> g <> " " <> m <> "> " ttyFrom :: Text -> StyledString ttyFrom = styled $ colored Yellow @@ -1787,18 +1757,13 @@ ttyFrom = styled $ colored Yellow ttyTo :: Text -> StyledString ttyTo = styled $ colored Cyan -ttyToGroup :: GroupInfo -> Maybe GroupMember -> StyledString -ttyToGroup g@GroupInfo {localDisplayName = n} dirMem = - membershipIncognito g <> ttyTo ("#" <> n <> toDirectMember dirMem <> " ") +ttyToGroup :: GroupInfo -> StyledString +ttyToGroup g@GroupInfo {localDisplayName = n} = + membershipIncognito g <> ttyTo ("#" <> n <> " ") -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)" +ttyToGroupEdited :: GroupInfo -> StyledString +ttyToGroupEdited g@GroupInfo {localDisplayName = n} = + membershipIncognito g <> ttyTo ("#" <> n <> " [edited] ") ttyFilePath :: FilePath -> StyledString ttyFilePath = plain diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index de6353d2e..9e5d4fe1c 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 6c804659e..d476285fc 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -8,9 +8,8 @@ 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 (..), XFTPFileConfig (..)) +import Simplex.Chat.Controller (ChatConfig (..)) import Simplex.Chat.Protocol (supportedChatVRange) import Simplex.Chat.Store (agentStoreFile, chatStoreFile) import Simplex.Chat.Types (GroupMemberRole (..)) @@ -82,21 +81,6 @@ 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 @@ -820,7 +804,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_ @@ -835,7 +819,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_ @@ -851,7 +835,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_ @@ -907,7 +891,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_ @@ -934,7 +918,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_ @@ -1010,6 +994,7 @@ 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: " @@ -1019,7 +1004,10 @@ testGroupMessageEditHistory = alice .<## ": hey 👋" alice .<## ": hello!" bob ##> "/item info #team hey" - bob <## "message not found by text: hey" + bob <##. "sent at: " + bob <##. "received at: " + bob <## "message history:" + bob .<## ": hey there" testGroupMessageDelete :: HasCallStack => FilePath -> IO () testGroupMessageDelete = @@ -1043,7 +1031,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_ @@ -1072,10 +1060,14 @@ testGroupMessageDelete = bob ##> ("/_update item #1 " <> msgItemId3 <> " text hi alice") bob <# "#team [edited] > alice hello!" bob <## " hi alice" - cath <# "#team bob> [edited] > alice hello!" - cath <## " hi alice" + concurrently_ + (alice <# "#team bob> [edited] hi alice") + ( do + cath <# "#team bob> [edited] > alice hello!" + cath <## " hi alice" + ) - alice #$> ("/_get chat #1 count=1", chat', [((0, "connected"), Nothing)]) + alice #$> ("/_get chat #1 count=1", chat', [((0, "hi alice"), 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!"))]) @@ -2694,534 +2686,3 @@ 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 05075f5b5..c120d661f 100644 --- a/tests/ChatTests/Utils.hs +++ b/tests/ChatTests/Utils.hs @@ -181,12 +181,7 @@ chatF :: String -> [((Int, String), Maybe String)] chatF = map (\(a, _, c) -> (a, c)) . chat'' chat'' :: String -> [((Int, String), Maybe (Int, String), Maybe String)] -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 +chat'' = read chatFeatures :: [(Int, String)] chatFeatures = map (\(a, _, _) -> a) chatFeatures'' @@ -461,33 +456,27 @@ showName (TestCC ChatController {currentUser} _ _ _ _ _) = do pure . T.unpack $ localDisplayName <> optionalFullName localDisplayName fullName createGroup2 :: HasCallStack => String -> TestCC -> TestCC -> IO () -createGroup2 gName cc1 cc2 = createGroup2' gName cc1 cc2 GRAdmin - -createGroup2' :: HasCallStack => String -> TestCC -> TestCC -> GroupMemberRole -> IO () -createGroup2' gName cc1 cc2 memberRole = do +createGroup2 gName cc1 cc2 = 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 memberRole + addMember gName cc1 cc2 GRAdmin 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 = 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 +createGroup3 gName cc1 cc2 cc3 = do + createGroup2 gName cc1 cc2 connectUsers cc1 cc3 name1 <- userName cc1 name3 <- userName cc3 sName2 <- showName cc2 sName3 <- showName cc3 - addMember gName cc1 cc3 memberRole + addMember gName cc1 cc3 GRAdmin cc3 ##> ("/j " <> gName) concurrentlyN_ [ cc1 <## ("#" <> gName <> ": " <> name3 <> " joined the group"), diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index f9421f691..3acc78e7d 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 Nothing) + (MsgRef (Just $ SharedMsgId "\5\6\7\8") (systemToUTCTime $ MkSystemTime 1 1) True Nothing) $ MCText "hello there!" (==##) :: MsgEncodingI e => ByteString -> ChatMessage e -> Expectation @@ -105,13 +105,10 @@ 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 Nothing)) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing (Just 3600) 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) 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))) + #==# XMsgNew (MCSimple (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) 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)) @@ -133,41 +130,27 @@ 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 Nothing))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing (Just 3600) 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) Nothing))) + (XMsgNew (MCQuote quotedMsg (ExtMsgContent (MCText "hello to you too") Nothing Nothing (Just True)))) 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 Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing (Just 3600) 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) Nothing)) + ##==## ChatMessage chatInitialVRange (Just $ SharedMsgId "\1\2\3\4") (XMsgNew $ MCForward (ExtMsgContent (MCText "hello") Nothing Nothing (Just True))) 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})))