diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c5c507b95..f7d310cc3 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -83,6 +83,7 @@ library Simplex.Chat.Migrations.M20230117_fkey_indexes Simplex.Chat.Migrations.M20230118_recreate_smp_servers Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx + Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.ProfileGenerator diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 4f4879662..c66c30161 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -418,7 +418,7 @@ processChatCommand = \case pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) where quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool) - quoteData ChatItem {meta = CIMeta {itemDeleted = True}} = throwChatError CEInvalidQuote + 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 @@ -472,7 +472,7 @@ processChatCommand = \case pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) where quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) - quoteData ChatItem {meta = CIMeta {itemDeleted = True}} _ = throwChatError CEInvalidQuote + 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 @@ -543,27 +543,34 @@ processChatCommand = \case (CIDMInternal, _, _) -> deleteDirectCI user ct ci True False (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do assertDirectAllowed user MDSnd ct XMsgDel_ - (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId) + (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId Nothing) setActive $ ActiveC c if featureAllowed SCFFullDelete forUser ct then deleteDirectCI user ct ci True False else markDirectCIDeleted user ct ci msgId True (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete CTGroup -> do - Group gInfo@GroupInfo {localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId - assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier + Group gInfo ms <- withStore $ \db -> getGroup db user chatId ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId case (mode, msgDir, itemSharedMsgId) of - (CIDMInternal, _, _) -> deleteGroupCI user gInfo ci True False + (CIDMInternal, _, _) -> deleteGroupCI user gInfo ci True False Nothing (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do - SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgDel itemSharedMId) - setActive $ ActiveG gName - if groupFeatureAllowed SGFFullDelete gInfo - then deleteGroupCI user gInfo ci True False - else markGroupCIDeleted user gInfo ci msgId True + assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier + SndMessage {msgId} <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId Nothing + delGroupChatItem user gInfo ci msgId (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 ms <- withStore $ \db -> getGroup db user gId + ci@(CChatItem _ ChatItem {chatDir, meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user gId itemId + case (chatDir, itemSharedMsgId) of + (CIGroupRcv GroupMember {groupMemberId, memberRole, memberId}, Just itemSharedMId) -> do + when (groupMemberId /= mId) $ throwChatError CEInvalidChatItemDelete + assertUserGroupRole gInfo $ max GRAdmin memberRole + SndMessage {msgId} <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId $ Just memberId + delGroupChatItem user gInfo ci msgId + (_, _) -> throwChatError CEInvalidChatItemDelete APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of CTDirect -> do user <- withStore $ \db -> getUserByContactId db chatId @@ -622,7 +629,7 @@ processChatCommand = \case Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId let isOwner = memberRole (membership :: GroupMember) == GROwner canDelete = isOwner || not (memberCurrent membership) - unless canDelete $ throwChatError $ CEGroupUserRole GROwner + unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo withChatLock "deleteChat group" . procCmd $ do deleteFilesAndConns user filesInfo @@ -1030,6 +1037,10 @@ processChatCommand = \case chatRef <- getChatRef user chatName deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg processChatCommand $ APIDeleteChatItem chatRef deletedItemId CIDMBroadcast + DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do + (gId, mId) <- getGroupAndMemberId user gName mName + deletedItemId <- withStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) $ safeDecodeUtf8 deletedMsg + processChatCommand $ APIDeleteMemberChatItem gId mId deletedItemId EditMessage chatName editedMsg msg -> withUser $ \user -> do chatRef <- getChatRef user chatName editedItemId <- getSentChatItemIdByText user chatRef editedMsg @@ -1467,10 +1478,16 @@ processChatCommand = \case pure $ CRGroupUpdated user g g' Nothing assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole g@GroupInfo {membership} requiredRole = do - when (memberRole (membership :: GroupMember) < requiredRole) $ throwChatError $ CEGroupUserRole requiredRole + when (memberRole (membership :: GroupMember) < requiredRole) $ throwChatError $ CEGroupUserRole g requiredRole when (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g) when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved unless (memberActive membership) $ throwChatError CEGroupMemberNotActive + delGroupChatItem :: User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> m ChatResponse + delGroupChatItem user gInfo@GroupInfo {localDisplayName = gName} ci msgId = do + setActive $ ActiveG gName + if groupFeatureAllowed SGFFullDelete gInfo + then deleteGroupCI user gInfo ci True False Nothing + else markGroupCIDeleted user gInfo ci msgId True Nothing updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse updateGroupProfileByName gName update = withUser $ \user -> do g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> @@ -1977,7 +1994,7 @@ deleteTimedItem user (ChatRef cType chatId, itemId) deleteAt = do deleteDirectCI user ct ci True True >>= toView CTGroup -> do (gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId - deleteGroupCI user gInfo ci True True >>= toView + deleteGroupCI user gInfo ci True True Nothing >>= toView _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType" startUpdatedTimedItemThread :: ChatMonad m => User -> ChatRef -> ChatItem c d -> ChatItem c d -> m () @@ -2144,7 +2161,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case event of XMsgNew mc -> newContentMessage ct mc msg msgMeta XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId -> messageDelete ct sharedMsgId msg msgMeta + XMsgDel sharedMsgId _ -> messageDelete ct sharedMsgId msg msgMeta -- TODO discontinue XFile XFile fInv -> processFileInvitation' ct fInv msg msgMeta XFileCancel sharedMsgId -> xFileCancel ct sharedMsgId msgMeta @@ -2356,7 +2373,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do case event of XMsgNew mc -> canSend $ newGroupContentMessage gInfo m mc msg msgMeta XMsgUpdate sharedMsgId mContent ttl live -> canSend $ groupMessageUpdate gInfo m sharedMsgId mContent msg msgMeta ttl live - XMsgDel sharedMsgId -> groupMessageDelete gInfo m sharedMsgId msg + XMsgDel sharedMsgId memberId -> groupMessageDelete gInfo m sharedMsgId memberId msg -- TODO discontinue XFile XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta XFileCancel sharedMsgId -> xFileCancelGroup gInfo m sharedMsgId msgMeta @@ -2810,18 +2827,30 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do else messageError "x.msg.update: group member attempted to update a message of another member" -- shouldn't happen now that query includes group member id (SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update" - groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> RcvMessage -> m () - groupMessageDelete gInfo@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId RcvMessage {msgId} = do - ci@(CChatItem msgDir ChatItem {chatDir}) <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId - case (msgDir, chatDir) of - (SMDRcv, CIGroupRcv m) -> - if sameMemberId memberId m - then - if groupFeatureAllowed SGFFullDelete gInfo - then deleteGroupCI user gInfo ci False False >>= toView - else markGroupCIDeleted user gInfo ci msgId False >>= toView - else messageError "x.msg.del: group member attempted to delete a message of another member" -- shouldn't happen now that query includes group member id - (SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete" + groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> m () + groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} = 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 + | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView + | otherwise -> deleteMsg mem ci + CIGroupSnd -> deleteMsg membership ci + Left e -> messageError $ "x.msg.del: message not found, " <> tshow e + where + deleteMsg :: GroupMember -> CChatItem 'CTGroup -> m () + deleteMsg mem ci = case sndMemberId_ of + Just sndMemberId + | sameMemberId sndMemberId mem -> checkRole mem $ delete ci (Just m) >>= toView + | otherwise -> messageError "x.msg.del: message of another member with incorrect memberId" + _ -> messageError "x.msg.del: message of another member without memberId" + checkRole GroupMember {memberRole} a + | senderRole < GRAdmin || senderRole < memberRole = + messageError "x.msg.del: message of another member with insufficient member permissions" + | otherwise = a + delete ci byGroupMember + | groupFeatureAllowed SGFFullDelete gInfo = deleteGroupCI user gInfo ci False False byGroupMember + | otherwise = markGroupCIDeleted user gInfo ci msgId False byGroupMember -- TODO remove once XFile is discontinued processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m () @@ -3329,7 +3358,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do xGrpDel :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m () xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg msgMeta = do - when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole GROwner + when (memberRole /= GROwner) $ throwChatError $ CEGroupUserRole gInfo GROwner ms <- withStore' $ \db -> do members <- getGroupMembers db user gInfo updateGroupMemberStatus db userId membership GSMemGroupDeleted @@ -3628,7 +3657,7 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs cur tz <- getCurrentTimeZone let itemText = ciContentToText content itemStatus = ciCreateStatus content - meta = mkCIMeta ciId content itemText itemStatus sharedMsgId False False itemTimed (justTrue live) tz currentTs itemTs currentTs currentTs + meta = mkCIMeta ciId content itemText itemStatus sharedMsgId Nothing False itemTimed (justTrue live) tz currentTs itemTs currentTs currentTs pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, file} deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse @@ -3637,11 +3666,14 @@ deleteDirectCI user ct ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser withStore' $ \db -> deleteDirectChatItem db user ct ci pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed -deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> m ChatResponse -deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do +deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> Maybe GroupMember -> m ChatResponse +deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ = do deleteCIFile user file - withStore' $ \db -> deleteGroupChatItem db user gInfo ci - pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) Nothing byUser timed + toCi <- withStore' $ \db -> + case byGroupMember_ of + Nothing -> deleteGroupChatItem db user gInfo ci $> Nothing + Just m -> Just <$> updateGroupChatItemModerated db user gInfo ci m + pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) toCi byUser timed deleteCIFile :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m () deleteCIFile user file = @@ -3655,9 +3687,9 @@ markDirectCIDeleted user ct ci@(CChatItem msgDir deletedItem) msgId byUser = do toCi <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser False -markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> m ChatResponse -markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser = do - toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId +markGroupCIDeleted :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> m ChatResponse +markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser byGroupMember_ = do + toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_ pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser False createAgentConnectionAsync :: forall m c. (ChatMonad m, ConnectionModeI c) => User -> CommandFunction -> Bool -> SConnectionMode c -> m (CommandId, ConnId) @@ -3927,6 +3959,7 @@ chatCommandP = "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> (" 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), "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))), "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), "/_delete " *> (APIDeleteChat <$> chatRefP), @@ -4038,6 +4071,7 @@ chatCommandP = (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> A.takeByteString), + ("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> A.takeByteString), ("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> A.takeByteString), "/feed " *> (SendMessageBroadcast <$> A.takeByteString), ("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))), diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index b50381ec5..4ccd0f1e1 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -203,6 +203,7 @@ data ChatCommand | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode + | APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) | APIChatUnread ChatRef Bool | APIDeleteChat ChatRef @@ -297,6 +298,7 @@ data ChatCommand | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString} | SendMessageBroadcast ByteString -- UserId (not used in UI) | DeleteMessage ChatName ByteString + | DeleteMemberMessage GroupName ContactName ByteString | EditMessage {chatName :: ChatName, editedMsg :: ByteString, message :: ByteString} | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: ByteString} | APINewGroup UserId GroupProfile @@ -657,7 +659,7 @@ data ChatErrorType | CEContactNotReady {contact :: Contact} | CEContactDisabled {contact :: Contact} | CEConnectionDisabled {connection :: Connection} - | CEGroupUserRole {requiredRole :: GroupMemberRole} + | CEGroupUserRole {groupInfo :: GroupInfo, requiredRole :: GroupMemberRole} | CEContactIncognitoCantInvite | CEGroupIncognitoCantInvite | CEGroupContactRole {contactName :: ContactName} diff --git a/src/Simplex/Chat/Messages.hs b/src/Simplex/Chat/Messages.hs index 497ce7bb6..f5a8c3046 100644 --- a/src/Simplex/Chat/Messages.hs +++ b/src/Simplex/Chat/Messages.hs @@ -19,6 +19,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as LB import Data.Int (Int64) +import Data.Maybe (isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1, encodeUtf8) @@ -121,7 +122,7 @@ instance ToJSON AChatInfo where data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem { chatDir :: CIDirection c d, - meta :: CIMeta d, + meta :: CIMeta c d, content :: CIContent d, formattedText :: Maybe MarkdownList, quotedItem :: Maybe (CIQuote c), @@ -183,6 +184,26 @@ chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs chatItemTimed :: ChatItem c d -> Maybe CITimed chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed +data CIDeletedState = CIDeletedState + { markedDeleted :: Bool, + deletedByMember :: Maybe GroupMember + } + deriving (Show, Eq) + +chatItemDeletedState :: ChatItem c d -> Maybe CIDeletedState +chatItemDeletedState ChatItem {meta = CIMeta {itemDeleted}, content} = + ciDeletedToDeletedState <$> itemDeleted + where + ciDeletedToDeletedState cid = + case content of + CISndModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid} + CIRcvModerated -> CIDeletedState {markedDeleted = False, deletedByMember = byMember cid} + _ -> CIDeletedState {markedDeleted = True, deletedByMember = byMember cid} + byMember :: CIDeleted c -> Maybe GroupMember + byMember = \case + CIModerated m -> Just m + CIDeleted -> Nothing + data ChatDirection (c :: ChatType) (d :: MsgDirection) where CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv @@ -277,13 +298,13 @@ instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where toEncoding = J.genericToEncoding J.defaultOptions -- This type is not saved to DB, so all JSON encodings are platform-specific -data CIMeta (d :: MsgDirection) = CIMeta +data CIMeta (c :: ChatType) (d :: MsgDirection) = CIMeta { itemId :: ChatItemId, itemTs :: ChatItemTs, itemText :: Text, itemStatus :: CIStatus d, itemSharedMsgId :: Maybe SharedMsgId, - itemDeleted :: Bool, + itemDeleted :: Maybe (CIDeleted c), itemEdited :: Bool, itemTimed :: Maybe CITimed, itemLive :: Maybe Bool, @@ -294,15 +315,15 @@ data CIMeta (d :: MsgDirection) = CIMeta } deriving (Show, Generic) -mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Bool -> Bool -> Maybe CITimed -> Maybe Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta d +mkCIMeta :: ChatItemId -> CIContent d -> Text -> CIStatus d -> Maybe SharedMsgId -> Maybe (CIDeleted c) -> Bool -> Maybe CITimed -> Maybe Bool -> TimeZone -> UTCTime -> ChatItemTs -> UTCTime -> UTCTime -> CIMeta c d mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive tz currentTs itemTs createdAt updatedAt = let localItemTs = utcToZonedTime tz itemTs editable = case itemContent of - CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && not itemDeleted + CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted _ -> False in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, localItemTs, createdAt, updatedAt} -instance ToJSON (CIMeta d) where toEncoding = J.genericToEncoding J.defaultOptions +instance ToJSON (CIMeta c d) where toEncoding = J.genericToEncoding J.defaultOptions data CITimed = CITimed { ttl :: Int, -- seconds @@ -629,6 +650,8 @@ data CIContent (d :: MsgDirection) where CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv CIRcvGroupFeatureRejected :: GroupFeature -> CIContent 'MDRcv + CISndModerated :: CIContent 'MDSnd + CIRcvModerated :: CIContent 'MDRcv -- ^ This type is used both in API and in DB, so we use different JSON encodings for the database and for the API -- ! ^ Nested sum types also have to use different encodings for database and API -- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent @@ -661,6 +684,7 @@ ciRequiresAttention content = case msgDirection @d of CIRcvGroupFeature {} -> False CIRcvChatFeatureRejected _ -> True CIRcvGroupFeatureRejected _ -> True + CIRcvModerated -> True ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d ciCreateStatus content = case msgDirection @d of @@ -820,6 +844,8 @@ ciContentToText = \case CISndGroupFeature feature pref param -> groupPrefStateText feature pref param CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited" CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited" + CISndModerated -> ciModeratedText + CIRcvModerated -> ciModeratedText msgIntegrityError :: MsgErrorType -> Text msgIntegrityError = \case @@ -830,10 +856,13 @@ msgIntegrityError = \case MsgBadHash -> "incorrect message hash" MsgDuplicate -> "duplicate message ID" -msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d -msgDirToDeletedContent_ msgDir mode = case msgDir of - SMDRcv -> CIRcvDeleted mode - SMDSnd -> CISndDeleted mode +msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d +msgDirToModeratedContent_ = \case + SMDRcv -> CIRcvModerated + SMDSnd -> CISndModerated + +ciModeratedText :: Text +ciModeratedText = "moderated" -- platform independent instance ToField (CIContent d) where @@ -878,6 +907,8 @@ data JSONCIContent | JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | JCIRcvChatFeatureRejected {feature :: ChatFeature} | JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} + | JCISndModerated + | JCIRcvModerated deriving (Generic) instance FromJSON JSONCIContent where @@ -910,6 +941,8 @@ jsonCIContent = \case CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param} CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature} CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature} + CISndModerated -> JCISndModerated + CIRcvModerated -> JCISndModerated aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON = \case @@ -934,6 +967,8 @@ aciContentJSON = \case JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature + JCISndModerated -> ACIContent SMDSnd CISndModerated + JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated -- platform independent data DBJSONCIContent @@ -958,6 +993,8 @@ data DBJSONCIContent | DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | DBJCIRcvChatFeatureRejected {feature :: ChatFeature} | DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} + | DBJCISndModerated + | DBJCIRcvModerated deriving (Generic) instance FromJSON DBJSONCIContent where @@ -990,6 +1027,8 @@ dbJsonCIContent = \case CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param} CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature} CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature} + CISndModerated -> DBJCISndModerated + CIRcvModerated -> DBJCIRcvModerated aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON = \case @@ -1014,6 +1053,8 @@ aciContentDBJSON = \case DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature + DBJCISndModerated -> ACIContent SMDSnd CISndModerated + DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated data CICallStatus = CISCallPending @@ -1241,3 +1282,27 @@ checkDirection :: forall t d d'. (MsgDirectionI d, MsgDirectionI d') => t d' -> checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of Just Refl -> Right x Nothing -> Left "bad direction" + +data CIDeleted (c :: ChatType) where + CIDeleted :: CIDeleted c + CIModerated :: GroupMember -> CIDeleted 'CTGroup + +deriving instance Show (CIDeleted c) + +instance ToJSON (CIDeleted d) where + toJSON = J.toJSON . jsonCIDeleted + toEncoding = J.toEncoding . jsonCIDeleted + +data JSONCIDeleted + = JCIDDeleted + | JCIDModerated {byGroupMember :: GroupMember} + deriving (Show, Generic) + +instance ToJSON JSONCIDeleted where + toJSON = J.genericToJSON . sumTypeJSON $ dropPrefix "JCID" + toEncoding = J.genericToEncoding . sumTypeJSON $ dropPrefix "JCID" + +jsonCIDeleted :: CIDeleted d -> JSONCIDeleted +jsonCIDeleted = \case + CIDeleted -> JCIDDeleted + CIModerated m -> JCIDModerated m diff --git a/src/Simplex/Chat/Migrations/M20230206_item_deleted_by_group_member_id.hs b/src/Simplex/Chat/Migrations/M20230206_item_deleted_by_group_member_id.hs new file mode 100644 index 000000000..085e7f752 --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20230206_item_deleted_by_group_member_id.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20230206_item_deleted_by_group_member_id :: Query +m20230206_item_deleted_by_group_member_id = + [sql| +ALTER TABLE chat_items ADD COLUMN item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL; + +CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items(item_deleted_by_group_member_id); +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 9638dad52..f5de4e6fb 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -372,7 +372,8 @@ CREATE TABLE chat_items( item_edited INTEGER, timed_ttl INTEGER, timed_delete_at TEXT, - item_live INTEGER + item_live INTEGER, + item_deleted_by_group_member_id INTEGER REFERENCES group_members ON DELETE SET NULL ); CREATE TABLE chat_item_messages( chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, @@ -546,3 +547,6 @@ CREATE TABLE IF NOT EXISTS "smp_servers"( UNIQUE(user_id, host, port) ); CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id); +CREATE INDEX idx_chat_items_item_deleted_by_group_member_id ON chat_items( + item_deleted_by_group_member_id +); diff --git a/src/Simplex/Chat/Protocol.hs b/src/Simplex/Chat/Protocol.hs index 6361056e4..69a7b10ca 100644 --- a/src/Simplex/Chat/Protocol.hs +++ b/src/Simplex/Chat/Protocol.hs @@ -180,7 +180,7 @@ instance StrEncoding AChatMessage where data ChatMsgEvent (e :: MsgEncoding) where XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> ChatMsgEvent 'Json - XMsgDel :: SharedMsgId -> ChatMsgEvent 'Json + XMsgDel :: SharedMsgId -> Maybe MemberId -> ChatMsgEvent 'Json XMsgDeleted :: ChatMsgEvent 'Json XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol @@ -558,7 +558,7 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e toCMEventTag msg = case msg of XMsgNew _ -> XMsgNew_ XMsgUpdate {} -> XMsgUpdate_ - XMsgDel _ -> XMsgDel_ + XMsgDel {} -> XMsgDel_ XMsgDeleted -> XMsgDeleted_ XFile _ -> XFile_ XFileAcpt _ -> XFileAcpt_ @@ -643,7 +643,7 @@ appJsonToCM AppMessageJson {msgId, event, params} = do msg = \case XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live" - XMsgDel_ -> XMsgDel <$> p "msgId" + XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId" XMsgDeleted_ -> pure XMsgDeleted XFile_ -> XFile <$> p "file" XFileAcpt_ -> XFileAcpt <$> p "fileName" @@ -696,7 +696,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of params = \case XMsgNew container -> msgContainerJSON container XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content] - XMsgDel msgId' -> o ["msgId" .= msgId'] + XMsgDel msgId' memberId -> o $ ("memberId" .=? memberId) ["msgId" .= msgId'] XMsgDeleted -> JM.empty XFile fileInv -> o ["file" .= fileInv] XFileAcpt fileName -> o ["fileName" .= fileName] diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index 4e27177e2..19fb15106 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -208,6 +208,7 @@ module Simplex.Chat.Store getDirectChatItemByAgentMsgId, getGroupChatItem, getGroupChatItemBySharedMsgId, + getGroupMemberCIBySharedMsgId, getDirectChatItemIdByText, getGroupChatItemIdByText, getChatItemByFileId, @@ -220,6 +221,7 @@ module Simplex.Chat.Store markDirectChatItemDeleted, updateGroupChatItem, deleteGroupChatItem, + updateGroupChatItemModerated, markGroupChatItemDeleted, updateDirectChatItemsRead, getDirectUnreadTimedItems, @@ -338,6 +340,7 @@ import Simplex.Chat.Migrations.M20230111_users_agent_user_id import Simplex.Chat.Migrations.M20230117_fkey_indexes import Simplex.Chat.Migrations.M20230118_recreate_smp_servers import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx +import Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Chat.Util (week) @@ -402,7 +405,8 @@ schemaMigrations = ("20230111_users_agent_user_id", m20230111_users_agent_user_id), ("20230117_fkey_indexes", m20230117_fkey_indexes), ("20230118_recreate_smp_servers", m20230118_recreate_smp_servers), - ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx) + ("20230129_drop_chat_items_group_idx", m20230129_drop_chat_items_group_idx), + ("20230206_item_deleted_by_group_member_id", m20230206_item_deleted_by_group_member_id) ] -- | The list of migrations in ascending order by date @@ -3511,7 +3515,11 @@ getGroupChatPreviews_ db User {userId, userContactId} = do -- 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, - rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences + rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences, + -- 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.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 @@ -3535,6 +3543,8 @@ getGroupChatPreviews_ db User {userId, userContactId} = do LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id 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) WHERE g.user_id = ? AND mu.contact_id = ? ORDER BY i.item_ts DESC |] @@ -4001,6 +4011,7 @@ updatedChatItem ci@ChatItem {meta = meta@CIMeta {itemStatus, itemEdited, itemTim updateDirectChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO () updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta + itemDeleted' = isJust itemDeleted DB.execute db [sql| @@ -4008,7 +4019,7 @@ updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? |] - ((content, itemText, itemStatus, itemDeleted, itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) + ((content, itemText, itemStatus, itemDeleted', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, contactId, itemId)) forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () @@ -4050,7 +4061,7 @@ markDirectChatItemDeleted db User {userId} ct@Contact {contactId} (CChatItem msg WHERE user_id = ? AND contact_id = ? AND chat_item_id = ? |] (currentTs, userId, contactId, itemId) - pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = True, editable = False}}) + pure $ AChatItem SCTDirect msgDir (DirectChat ct) (ci {meta = (meta ci) {itemDeleted = Just (CIDeleted @'CTDirect), editable = False}}) getDirectChatItemBySharedMsgId :: DB.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect) getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do @@ -4126,6 +4137,7 @@ updateGroupChatItem db user groupId ci newContent live msgId_ = do updateGroupChatItem_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO () updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta + itemDeleted' = isJust itemDeleted DB.execute db [sql| @@ -4133,7 +4145,7 @@ updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = SET item_content = ?, item_text = ?, item_status = ?, item_deleted = ?, item_deleted = 0, item_edited = ?, item_live = ?, updated_at = ?, timed_ttl = ?, timed_delete_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] - ((content, itemText, itemStatus, itemDeleted, itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) + ((content, itemText, itemStatus, itemDeleted', itemEdited, itemLive, updatedAt) :. ciTimedRow itemTimed :. (userId, groupId, itemId)) forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () @@ -4148,20 +4160,41 @@ deleteGroupChatItem db User {userId} GroupInfo {groupId} (CChatItem _ ci) = do |] (userId, groupId, itemId) -markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> IO AChatItem -markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId = do +updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> IO AChatItem +updateGroupChatItemModerated db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) m@GroupMember {groupMemberId} = do + currentTs <- getCurrentTime + let toContent = msgDirToModeratedContent_ msgDir + toText = ciModeratedText + itemId = chatItemId' ci + deleteChatItemMessages_ db itemId + liftIO $ + DB.execute + db + [sql| + UPDATE chat_items + SET item_deleted = 1, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ? + WHERE user_id = ? AND group_id = ? AND chat_item_id = ? + |] + (groupMemberId, toContent, toText, currentTs, userId, groupId, itemId) + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {content = toContent, meta = (meta ci) {itemText = toText, itemDeleted = Just (CIModerated m)}, formattedText = Nothing}) + +markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Maybe GroupMember -> IO AChatItem +markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId byGroupMember_ = do currentTs <- liftIO getCurrentTime let itemId = chatItemId' ci + (deletedByGroupMemberId, ciDeleted) = case byGroupMember_ of + Just m@GroupMember {groupMemberId} -> (Just groupMemberId, CIModerated m) + _ -> (Nothing, CIDeleted) insertChatItemMessage_ db itemId msgId currentTs DB.execute db [sql| UPDATE chat_items - SET item_deleted = 1, updated_at = ? + SET item_deleted = 1, item_deleted_by_group_member_id = ?, updated_at = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ? |] - (currentTs, userId, groupId, itemId) - pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = True, editable = False}}) + (deletedByGroupMemberId, currentTs, userId, groupId, itemId) + pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = Just ciDeleted, editable = False}}) getGroupChatItemBySharedMsgId :: DB.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do @@ -4170,15 +4203,34 @@ getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId shared DB.query db [sql| - SELECT chat_item_id - FROM chat_items - WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? - ORDER BY chat_item_id DESC - LIMIT 1 - |] + SELECT chat_item_id + FROM chat_items + WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? + ORDER BY chat_item_id DESC + LIMIT 1 + |] (userId, groupId, groupMemberId, sharedMsgId) getGroupChatItem db user groupId itemId +getGroupMemberCIBySharedMsgId :: DB.Connection -> User -> GroupId -> MemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup) +getGroupMemberCIBySharedMsgId db user@User {userId} groupId memberId sharedMsgId = do + itemId <- + ExceptT . firstRow fromOnly (SEChatItemSharedMsgIdNotFound sharedMsgId) $ + DB.query + db + [sql| + SELECT i.chat_item_id + FROM chat_items i + JOIN group_members m ON m.group_id = i.group_id + AND ((i.group_member_id IS NULL AND m.member_category = ?) + OR i.group_member_id = m.group_member_id) + WHERE i.user_id = ? AND i.group_id = ? AND m.member_id = ? AND i.shared_msg_id = ? + ORDER BY i.chat_item_id DESC + LIMIT 1 + |] + (GCUserMember, userId, groupId, memberId, sharedMsgId) + getGroupChatItem db user groupId itemId + getGroupChatItem :: DB.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup) getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do tz <- getCurrentTimeZone @@ -4203,7 +4255,11 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do -- 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, - rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences + rp.display_name, rp.full_name, rp.image, rp.local_alias, rp.preferences, + -- 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.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 @@ -4211,6 +4267,8 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do LEFT JOIN chat_items ri ON ri.shared_msg_id = i.quoted_shared_msg_id AND ri.group_id = i.group_id LEFT JOIN group_members rm ON rm.group_member_id = ri.group_member_id 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) WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ? |] (userId, groupId, itemId) @@ -4482,8 +4540,11 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat cItem d chatDir ciStatus content file = CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file} badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta d - ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt + ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d + ciMeta content status = + let itemDeleted' = if itemDeleted then Just (CIDeleted @'CTDirect) else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} @@ -4494,7 +4555,7 @@ toDirectChatItemList _ _ _ = [] type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow -type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow +type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ @@ -4504,19 +4565,20 @@ toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction direction (Just False) Nothing = Just $ CIQGroupRcv Nothing direction _ _ = Nothing -toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup) -toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. quoteRow :. quotedMemberRow_) = do +toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow -> Either StoreError (CChatItem 'CTGroup) +toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. (fileId_, fileName_, fileSize_, filePath, fileStatus_)) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = do let member_ = toMaybeGroupMember userContactId memberRow_ - let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ + quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ + deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_ case (itemContent, itemStatus, member_, fileStatus_) of (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_ (ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Nothing) -> - Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing + Right $ cItem SMDSnd CIGroupSnd ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_ (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Just (AFS SMDRcv fileStatus)) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ (maybeCIFile fileStatus) deletedByGroupMember_ (ACIContent SMDRcv ciContent, ACIStatus SMDRcv ciStatus, Just member, Nothing) -> - Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing + Right $ cItem SMDRcv (CIGroupRcv member) ciStatus ciContent quotedMember_ Nothing deletedByGroupMember_ _ -> badItem where maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) @@ -4524,18 +4586,24 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT case (fileId_, fileName_, fileSize_) of (Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus} _ -> Nothing - cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> CChatItem 'CTGroup - cItem d chatDir ciStatus content quotedMember_ file = - CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} + cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> Maybe GroupMember -> CChatItem 'CTGroup + cItem d chatDir ciStatus content quotedMember_ file deletedByGroupMember_ = + CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus deletedByGroupMember_, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} badItem = Left $ SEBadChatItem itemId - ciMeta :: CIContent d -> CIStatus d -> CIMeta d - ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt + ciMeta :: CIContent d -> CIStatus d -> Maybe GroupMember -> CIMeta 'CTGroup d + ciMeta content status deletedByGroupMember_ = + let itemDeleted' = + if itemDeleted + then Just (maybe (CIDeleted @'CTGroup) CIModerated deletedByGroupMember_) + else Nothing + itemEdited' = fromMaybe False itemEdited + in mkCIMeta itemId content itemText status sharedMsgId itemDeleted' itemEdited' ciTimed itemLive tz currentTs itemTs createdAt updatedAt ciTimed :: Maybe CITimed ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] -toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) = - either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. quoteRow :. quotedMemberRow_) +toGroupChatItemList tz currentTs userContactId (((Just itemId, Just itemTs, Just itemContent, Just itemText, Just itemStatus, sharedMsgId, Just itemDeleted, itemEdited, Just createdAt, Just updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) = + either (const []) (: []) $ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemText, itemStatus, sharedMsgId, itemDeleted, itemEdited, createdAt, updatedAt) :. (timedTTL, timedDeleteAt, itemLive) :. fileRow) :. memberRow_ :. (quoteRow :. quotedMemberRow_) :. deletedByGroupMemberRow_) toGroupChatItemList _ _ _ _ = [] getSMPServers :: DB.Connection -> User -> IO [ServerCfg] diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 709a88530..e99f800e5 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -19,7 +19,7 @@ import Data.Function (on) import Data.Int (Int64) import Data.List (groupBy, intercalate, intersperse, partition, sortOn) import qualified Data.List.NonEmpty as L -import Data.Maybe (isJust, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (DiffTime, UTCTime) @@ -84,7 +84,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId] CRChatItemStatusUpdated u _ -> ttyUser u [] CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts - CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem (isJust toItem) byUser timed ts + CRChatItemDeleted u (AChatItem _ _ chat deletedItem) toItem byUser timed -> ttyUser u $ unmuted chat deletedItem $ viewItemDelete chat deletedItem toItem byUser timed ts testView CRChatItemDeletedNotFound u Contact {localDisplayName = c} _ -> ttyUser u [ttyFrom $ c <> "> [deleted - original message not found]"] CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts t CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr @@ -266,7 +266,7 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case Just CIFile {filePath = Just fp} -> Just fp _ -> Nothing testViewItem :: CChatItem c -> Text - testViewItem (CChatItem _ ChatItem {meta = CIMeta {itemText, itemDeleted}}) = itemText <> if itemDeleted then " [marked deleted]" else "" + testViewItem (CChatItem _ ci@ChatItem {meta = CIMeta {itemText}}) = itemText <> maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci) viewErrorsSummary :: [a] -> StyledString -> [StyledString] viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)] contactList :: [ContactRef] -> String @@ -276,6 +276,15 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case | muted chat chatItem = [] | otherwise = s +chatItemDeletedText :: ChatItem c d -> Maybe Text +chatItemDeletedText ci = deletedStateToText <$> chatItemDeletedState ci + where + deletedStateToText = \CIDeletedState {markedDeleted, deletedByMember} -> + if markedDeleted + then "marked deleted" <> byMember deletedByMember + else "deleted" <> byMember deletedByMember + byMember m_ = maybe "" (\GroupMember {localDisplayName = m} -> " by " <> m) m_ + viewUsersList :: [UserInfo] -> [StyledString] viewUsersList = map userInfo . sortOn ldn where @@ -316,7 +325,7 @@ viewChats ts = concatMap chatPreview . reverse _ -> [] viewChatItem :: forall c d. MsgDirectionI d => ChatInfo c -> ChatItem c d -> Bool -> CurrentTime -> [StyledString] -viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quotedItem, file} doShow ts = +viewChatItem chat ci@ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quotedItem, file} doShow ts = withItemDeleted <$> case chat of DirectChat c -> case chatDir of CIDirectSnd -> case content of @@ -352,7 +361,7 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content, quote = maybe [] (groupQuote g) quotedItem _ -> [] where - withItemDeleted item = if itemDeleted then item <> styled (colored Red) (" [marked deleted]" :: String) else item + withItemDeleted item = if isJust itemDeleted then item <> styled (colored Red) (T.unpack $ maybe "" (\t -> " [" <> t <> "]") (chatItemDeletedText ci)) else item withSndFile = withFile viewSentFileInvitation withRcvFile = withFile viewReceivedFileInvitation withFile view dir l = maybe l (\f -> l <> view dir f ts meta) file @@ -404,23 +413,28 @@ viewItemUpdate chat ChatItem {chatDir, meta = meta@CIMeta {itemEdited, itemLive} quote = maybe [] (groupQuote g) quotedItem _ -> [] -hideLive :: CIMeta d -> [StyledString] -> [StyledString] +hideLive :: CIMeta с d -> [StyledString] -> [StyledString] hideLive CIMeta {itemLive = Just True} _ = [] hideLive _ s = s -viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> Bool -> CurrentTime -> [StyledString] -viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser timed ts - | timed = [] - | byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"] +viewItemDelete :: ChatInfo c -> ChatItem c d -> Maybe AChatItem -> Bool -> Bool -> CurrentTime -> Bool -> [StyledString] +viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} toItem byUser timed ts testView + | timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView] + | byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here | otherwise = case chat of DirectChat c -> case (chatDir, deletedContent) of - (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c markedDeleted) [] mc ts meta + (CIDirectRcv, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromContactDeleted c deletedText_) [] mc ts meta _ -> prohibited - GroupChat g -> case (chatDir, deletedContent) of - (CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta + GroupChat g@GroupInfo {membership} -> case (chatDir, deletedContent) of + (CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m deletedText_) [] mc ts meta + (CIGroupSnd, CISndMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g membership deletedText_) [] mc ts meta _ -> prohibited _ -> prohibited where + deletedText_ :: Maybe Text + deletedText_ = case toItem of + Nothing -> Just "deleted" + Just (AChatItem _ _ _ ci) -> chatItemDeletedText ci prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)] directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString] @@ -445,7 +459,7 @@ msgPreview = msgPlain . preview . msgContentText | T.length t <= 120 = t | otherwise = T.take 120 t <> "..." -viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> CIMeta 'MDRcv -> [StyledString] +viewRcvIntegrityError :: StyledString -> MsgErrorType -> CurrentTime -> CIMeta с 'MDRcv -> [StyledString] viewRcvIntegrityError from msgErr ts meta = receivedWithTime_ ts from [] meta (viewMsgIntegrityError msgErr) False viewMsgIntegrityError :: MsgErrorType -> [StyledString] @@ -929,22 +943,22 @@ viewContactUpdated where fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' -viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString] viewReceivedMessage = viewReceivedMessage_ False -viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString] viewReceivedUpdatedMessage = viewReceivedMessage_ True -viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedMessage_ :: Bool -> StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString] viewReceivedMessage_ updated from quote mc ts meta = receivedWithTime_ ts from quote meta (ttyMsgContent mc) updated -receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta d -> [StyledString] -> Bool -> [StyledString] +receivedWithTime_ :: CurrentTime -> StyledString -> [StyledString] -> CIMeta c d -> [StyledString] -> Bool -> [StyledString] receivedWithTime_ ts from quote CIMeta {localItemTs, itemId, itemEdited, itemDeleted, itemLive} styledMsg updated = do prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg) where indent = if null quote then "" else " " live - | itemEdited || itemDeleted = "" + | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of Just True | updated -> ttyFrom "[LIVE] " @@ -963,12 +977,12 @@ ttyMsgTime ts t = else "%H:%M" in styleTime $ formatTime defaultTimeLocale fmt localTime -viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] +viewSentMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString] viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts (prependFirst to $ quote <> prependFirst (indent <> live) (ttyMsgContent mc)) meta where indent = if null quote then "" else " " live - | itemEdited || itemDeleted = "" + | itemEdited || isJust itemDeleted = "" | otherwise = case itemLive of Just True -> ttyTo "[LIVE started] " Just False -> ttyTo "[LIVE] " @@ -977,7 +991,7 @@ viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} = viewSentBroadcast :: MsgContent -> Int -> CurrentTime -> ZonedTime -> [StyledString] viewSentBroadcast mc n ts t = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts t <> " ") (ttyMsgContent mc) -viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta d -> [StyledString] +viewSentFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta c d -> [StyledString] viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePath of Just fPath -> sentWithTime_ ts $ ttySentFile fPath _ -> const [] @@ -987,7 +1001,7 @@ viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePa CIFSSndTransfer -> [] _ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"] -sentWithTime_ :: CurrentTime -> [StyledString] -> CIMeta d -> [StyledString] +sentWithTime_ :: CurrentTime -> [StyledString] -> CIMeta c d -> [StyledString] sentWithTime_ ts styledMsg CIMeta {localItemTs} = prependFirst (ttyMsgTime ts localItemTs <> " ") styledMsg @@ -1018,7 +1032,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} = sndFile :: SndFileTransfer -> StyledString sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName -viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta d -> [StyledString] +viewReceivedFileInvitation :: StyledString -> CIFile d -> CurrentTime -> CIMeta c d -> [StyledString] viewReceivedFileInvitation from file ts meta = receivedWithTime_ ts from [] meta (receivedFileInvitation_ file) False receivedFileInvitation_ :: CIFile d -> [StyledString] @@ -1199,9 +1213,10 @@ viewChatError logLevel = \case CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning] CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"] CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"] - CEGroupUserRole role -> case role of - GRAuthor -> ["you don't have permission to send messages to this group"] - _ -> ["you have insufficient permissions for this action, the required role is " <> plain (strEncode role)] + CEGroupUserRole g role -> + (: []) . (ttyGroup' g <>) $ case role of + GRAuthor -> ": you don't have permission to send messages" + _ -> ": you have insufficient permissions for this action, the required role is " <> plain (strEncode role) CEContactIncognitoCantInvite -> ["you're using your main profile for this group - prohibited to invite contacts to whom you are connected incognito"] CEGroupIncognitoCantInvite -> ["you've connected to this group using an incognito profile - prohibited to invite contacts"] CEGroupContactRole c -> ["contact " <> ttyContact c <> " has insufficient permissions for this group action"] @@ -1356,11 +1371,9 @@ ttyFromContact ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c ttyFromContactEdited :: Contact -> StyledString ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ") -ttyFromContactDeleted :: Contact -> Bool -> StyledString -ttyFromContactDeleted ct@Contact {localDisplayName = c} markedDeleted = - ctIncognito ct <> ttyFrom (c <> "> " <> deleted) - where - deleted = if markedDeleted then "[marked deleted] " else "[deleted] " +ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString +ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ = + ctIncognito ct <> ttyFrom (c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) ttyGroup :: GroupName -> StyledString ttyGroup g = styled (colored Blue) $ "#" <> g @@ -1383,11 +1396,9 @@ ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m) ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") -ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Bool -> StyledString -ttyFromGroupDeleted g m markedDeleted = - membershipIncognito g <> ttyFrom (fromGroup_ g m <> deleted) - where - deleted = if markedDeleted then "[marked deleted] " else "[deleted] " +ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString +ttyFromGroupDeleted g m deletedText_ = + membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_) fromGroup_ :: GroupInfo -> GroupMember -> Text fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = diff --git a/tests/ChatTests/Direct.hs b/tests/ChatTests/Direct.hs index a37edad46..0e6d535b1 100644 --- a/tests/ChatTests/Direct.hs +++ b/tests/ChatTests/Direct.hs @@ -1388,6 +1388,11 @@ testUsersTimedMessages tmp = do threadDelay 1000000 + alice <## "[user: alice] timed message deleted: alice 1" + alice <## "[user: alice] timed message deleted: alice 2" + bob <## "timed message deleted: alice 1" + bob <## "timed message deleted: alice 2" + alice ##> "/user alice" showActiveUser alice "alice (Alice)" alice #$> ("/_get chat @2 count=100", chat, []) @@ -1398,6 +1403,11 @@ testUsersTimedMessages tmp = do threadDelay 1000000 + alice <## "timed message deleted: alisa 1" + alice <## "timed message deleted: alisa 2" + bob <## "timed message deleted: alisa 1" + bob <## "timed message deleted: alisa 2" + alice ##> "/user" showActiveUser alice "alisa" alice #$> ("/_get chat @4 count=100", chat, []) @@ -1435,6 +1445,11 @@ testUsersTimedMessages tmp = do -- messages are deleted after restart threadDelay 1000000 + alice <## "[user: alice] timed message deleted: alice 3" + alice <## "[user: alice] timed message deleted: alice 4" + bob <## "timed message deleted: alice 3" + bob <## "timed message deleted: alice 4" + alice ##> "/user alice" showActiveUser alice "alice (Alice)" alice #$> ("/_get chat @2 count=100", chat, []) @@ -1445,6 +1460,11 @@ testUsersTimedMessages tmp = do threadDelay 1000000 + alice <## "timed message deleted: alisa 3" + alice <## "timed message deleted: alisa 4" + bob <## "timed message deleted: alisa 3" + bob <## "timed message deleted: alisa 4" + alice ##> "/user" showActiveUser alice "alisa" alice #$> ("/_get chat @4 count=100", chat, []) diff --git a/tests/ChatTests/Groups.hs b/tests/ChatTests/Groups.hs index 116f02917..281d069cb 100644 --- a/tests/ChatTests/Groups.hs +++ b/tests/ChatTests/Groups.hs @@ -35,6 +35,8 @@ chatGroupTests = do it "update member role" testUpdateMemberRole it "unused contacts are deleted after all their groups are deleted" testGroupDeleteUnusedContacts it "group description is shown as the first message to new members" testGroupDescription + it "delete message of another group member" testGroupMemberMessageDelete + it "full delete message of another group member" testGroupMemberMessageFullDelete describe "async group connections" $ do xit "create and join group when clients go offline" testGroupAsync describe "group links" $ do @@ -133,9 +135,9 @@ testGroupShared alice bob cath checkMessages = do -- cath <## "#team: alice changed the role of bob from admin to observer" -- ] -- bob ##> "#team hello" - -- bob <## "you don't have permission to send messages to this group" + -- bob <## "#team: you don't have permission to send messages to this group" -- bob ##> "/rm team cath" - -- bob <## "you have insufficient permissions for this action, the required role is admin" + -- bob <## "#team: you have insufficient permissions for this action, the required role is admin" -- cath #> "#team hello" -- concurrentlyN_ -- [ alice <# "#team cath> hello", @@ -981,7 +983,7 @@ testUpdateGroupProfile = (bob <# "#team alice> hello!") (cath <# "#team alice> hello!") bob ##> "/gp team my_team" - bob <## "you have insufficient permissions for this action, the required role is owner" + bob <## "#team: you have insufficient permissions for this action, the required role is owner" alice ##> "/gp team my_team" alice <## "changed to #my_team" concurrentlyN_ @@ -1016,13 +1018,13 @@ testUpdateMemberRole = (bob <## "#team: you joined the group") connectUsers bob cath bob ##> "/a team cath" - bob <## "you have insufficient permissions for this action, the required role is admin" + bob <## "#team: you have insufficient permissions for this action, the required role is admin" alice ##> "/mr team bob admin" concurrently_ (alice <## "#team: you changed the role of bob from member to admin") (bob <## "#team: alice changed your role from member to admin") bob ##> "/a team cath owner" - bob <## "you have insufficient permissions for this action, the required role is owner" + bob <## "#team: you have insufficient permissions for this action, the required role is owner" addMember "team" bob cath GRMember cath ##> "/j team" concurrentlyN_ @@ -1041,7 +1043,7 @@ testUpdateMemberRole = cath <## "#team: alice changed the role from owner to admin" ] alice ##> "/d #team" - alice <## "you have insufficient permissions for this action, the required role is owner" + alice <## "#team: you have insufficient permissions for this action, the required role is owner" testGroupDeleteUnusedContacts :: HasCallStack => FilePath -> IO () testGroupDeleteUnusedContacts = @@ -1195,6 +1197,75 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile cc <## "#team: bob added dan (Daniel) to the group (connecting...)" cc <## "#team: new member dan is connected" +testGroupMemberMessageDelete :: HasCallStack => FilePath -> IO () +testGroupMemberMessageDelete = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + alice ##> "/mr team cath member" + concurrentlyN_ + [ alice <## "#team: you changed the role of cath from admin to member", + bob <## "#team: alice changed the role of cath from admin to member", + cath <## "#team: alice changed your role from admin to member" + ] + alice #> "#team hello" + concurrently_ + (bob <# "#team alice> hello") + (cath <# "#team alice> hello") + bob ##> "\\\\ #team @alice hello" + bob <## "#team: you have insufficient permissions for this action, the required role is owner" + threadDelay 1000000 + cath #> "#team hi" + concurrently_ + (alice <# "#team cath> hi") + (bob <# "#team cath> hi") + bob ##> "\\\\ #team @cath hi" + bob <## "message marked deleted" + concurrently_ + (alice <# "#team cath> [marked deleted by bob] hi") + (cath <# "#team cath> [marked deleted by bob] hi") + alice #$> ("/_get chat #1 count=1", chat, [(0, "hi [marked deleted by bob]")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "hi [marked deleted]")]) + cath #$> ("/_get chat #1 count=1", chat, [(1, "hi [marked deleted by bob]")]) + +testGroupMemberMessageFullDelete :: HasCallStack => FilePath -> IO () +testGroupMemberMessageFullDelete = + testChat3 aliceProfile bobProfile cathProfile $ + \alice bob cath -> do + createGroup3 "team" alice bob cath + alice ##> "/mr team cath member" + concurrentlyN_ + [ alice <## "#team: you changed the role of cath from admin to member", + bob <## "#team: alice changed the role of cath from admin to member", + cath <## "#team: alice changed your role from admin to member" + ] + alice ##> "/set delete #team on" + alice <## "updated group preferences:" + alice <## "Full deletion: on" + concurrentlyN_ + [ do + bob <## "alice updated group #team:" + bob <## "updated group preferences:" + bob <## "Full deletion: on", + do + cath <## "alice updated group #team:" + cath <## "updated group preferences:" + cath <## "Full deletion: on" + ] + threadDelay 1000000 + cath #> "#team hi" + concurrently_ + (alice <# "#team cath> hi") + (bob <# "#team cath> hi") + bob ##> "\\\\ #team @cath hi" + bob <## "message deleted" + concurrently_ + (alice <# "#team cath> [deleted by bob] hi") + (cath <# "#team cath> [deleted by bob] hi") + alice #$> ("/_get chat #1 count=1", chat, [(0, "moderated [deleted by bob]")]) + bob #$> ("/_get chat #1 count=1", chat, [(0, "Full deletion: on")]) -- fully deleted for bob + cath #$> ("/_get chat #1 count=1", chat, [(1, "moderated [deleted by bob]")]) + testGroupAsync :: HasCallStack => FilePath -> IO () testGroupAsync tmp = do print (0 :: Integer) diff --git a/tests/ChatTests/Profiles.hs b/tests/ChatTests/Profiles.hs index 35f1ff81d..1e86ca487 100644 --- a/tests/ChatTests/Profiles.hs +++ b/tests/ChatTests/Profiles.hs @@ -1234,6 +1234,10 @@ testEnableTimedMessagesContact = alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "you offered Disappearing messages (1 sec)"), (0, "Disappearing messages: enabled (1 sec)"), (1, "hi"), (0, "hey")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "offered Disappearing messages (1 sec)"), (1, "Disappearing messages: enabled (1 sec)"), (0, "hi"), (1, "hey")]) threadDelay 1000000 + alice <## "timed message deleted: hi" + alice <## "timed message deleted: hey" + bob <## "timed message deleted: hi" + bob <## "timed message deleted: hey" alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "you offered Disappearing messages (1 sec)"), (0, "Disappearing messages: enabled (1 sec)")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "offered Disappearing messages (1 sec)"), (1, "Disappearing messages: enabled (1 sec)")]) -- turn off, messages are not disappearing @@ -1277,6 +1281,8 @@ testEnableTimedMessagesGroup = alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on (1 sec)"), (1, "hi")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)"), (0, "hi")]) threadDelay 1000000 + alice <## "timed message deleted: hi" + bob <## "timed message deleted: hi" alice #$> ("/_get chat #1 count=100", chat, [(0, "connected"), (1, "Disappearing messages: on (1 sec)")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)")]) -- turn off, messages are not disappearing @@ -1324,5 +1330,9 @@ testTimedMessagesEnabledGlobally = alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)"), (1, "hi"), (0, "hey")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)"), (0, "hi"), (1, "hey")]) threadDelay 1000000 + alice <## "timed message deleted: hi" + bob <## "timed message deleted: hi" + alice <## "timed message deleted: hey" + bob <## "timed message deleted: hey" alice #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(0, "Disappearing messages: enabled (1 sec)")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")]) diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 7abd76176..be5df905b 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -171,7 +171,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing it "x.msg.del" $ "{\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}" - #==# XMsgDel (SharedMsgId "\1\2\3\4") + #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing it "x.msg.deleted" $ "{\"event\":\"x.msg.deleted\",\"params\":{}}" #==# XMsgDeleted