IntenseFinance/simplex-chat
3
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

core: allow admins/owners delete member messages (#1869)

Browse Source 
* core: allow admins/owners delete member messages

* allow message deletion to admins/owners

* deleted by types, schema

* check role

* fix test, view

* view, tests

* comment

* test timed deletion events

* refactor

* refactor

* refactor

---------

Co-authored-by: JRoberts <8711996+jr-simplex@users.noreply.github.com>
This commit is contained in:
Evgeny Poberezkin 2023-02-08 07:08:53 +00:00 committed by GitHub
parent a018e4a581
commit 9e4499de6d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
13 changed files with 431 additions and 131 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
simplex-chat.cabal
View File

@ -83,6 +83,7 @@ library
Simplex.Chat.Migrations.M20230117_fkey_indexes Simplex.Chat.Migrations.M20230117_fkey_indexes
Simplex.Chat.Migrations.M20230118_recreate_smp_servers Simplex.Chat.Migrations.M20230118_recreate_smp_servers
Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx
Simplex.Chat.Migrations.M20230206_item_deleted_by_group_member_id
Simplex.Chat.Mobile Simplex.Chat.Mobile
Simplex.Chat.Options Simplex.Chat.Options
Simplex.Chat.ProfileGenerator Simplex.Chat.ProfileGenerator

108
src/Simplex/Chat.hs
View File

@ -418,7 +418,7 @@ processChatCommand = \case
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
where where
quoteData :: ChatItem c d -> m (MsgContent, CIQDirection 'CTDirect, Bool) 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 = CISndMsgContent qmc} = pure (qmc, CIQDirectSnd, True)
quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False) quoteData ChatItem {content = CIRcvMsgContent qmc} = pure (qmc, CIQDirectRcv, False)
quoteData _ = throwChatError CEInvalidQuote quoteData _ = throwChatError CEInvalidQuote
@ -472,7 +472,7 @@ processChatCommand = \case
pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem) pure (MCQuote QuotedMsg {msgRef, content = qmc} (ExtMsgContent mc fileInvitation_ (ttl' <$> timed_) (justTrue live)), Just quotedItem)
where where
quoteData :: ChatItem c d -> GroupMember -> m (MsgContent, CIQDirection 'CTGroup, Bool, GroupMember) 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 = 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 ChatItem {chatDir = CIGroupRcv m, content = CIRcvMsgContent qmc} _ = pure (qmc, CIQGroupRcv $ Just m, False, m)
quoteData _ _ = throwChatError CEInvalidQuote quoteData _ _ = throwChatError CEInvalidQuote
@ -543,27 +543,34 @@ processChatCommand = \case
(CIDMInternal, _, _) -> deleteDirectCI user ct ci True False (CIDMInternal, _, _) -> deleteDirectCI user ct ci True False
(CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
assertDirectAllowed user MDSnd ct XMsgDel_ assertDirectAllowed user MDSnd ct XMsgDel_
(SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId) (SndMessage {msgId}, _) <- sendDirectContactMessage ct (XMsgDel itemSharedMId Nothing)
setActive $ ActiveC c setActive $ ActiveC c
if featureAllowed SCFFullDelete forUser ct if featureAllowed SCFFullDelete forUser ct
then deleteDirectCI user ct ci True False then deleteDirectCI user ct ci True False
else markDirectCIDeleted user ct ci msgId True else markDirectCIDeleted user ct ci msgId True
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
CTGroup -> do CTGroup -> do
Group gInfo@GroupInfo {localDisplayName = gName} ms <- withStore $ \db -> getGroup db user chatId Group gInfo ms <- withStore $ \db -> getGroup db user chatId
assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId ci@(CChatItem msgDir ChatItem {meta = CIMeta {itemSharedMsgId}}) <- withStore $ \db -> getGroupChatItem db user chatId itemId
case (mode, msgDir, itemSharedMsgId) of 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 (CIDMBroadcast, SMDSnd, Just itemSharedMId) -> do
SndMessage {msgId} <- sendGroupMessage user gInfo ms (XMsgDel itemSharedMId) assertUserGroupRole gInfo GRObserver -- can still delete messages sent earlier
setActive $ ActiveG gName SndMessage {msgId} <- sendGroupMessage user gInfo ms $ XMsgDel itemSharedMId Nothing
if groupFeatureAllowed SGFFullDelete gInfo delGroupChatItem user gInfo ci msgId
then deleteGroupCI user gInfo ci True False
else markGroupCIDeleted user gInfo ci msgId True
(CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete (CIDMBroadcast, _, _) -> throwChatError CEInvalidChatItemDelete
CTContactRequest -> pure $ chatCmdError (Just user) "not supported" CTContactRequest -> pure $ chatCmdError (Just user) "not supported"
CTContactConnection -> 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 APIChatRead (ChatRef cType chatId) fromToIds -> withUser $ \_ -> case cType of
CTDirect -> do CTDirect -> do
user <- withStore $ \db -> getUserByContactId db chatId user <- withStore $ \db -> getUserByContactId db chatId
@ -622,7 +629,7 @@ processChatCommand = \case
Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db user chatId
let isOwner = memberRole (membership :: GroupMember) == GROwner let isOwner = memberRole (membership :: GroupMember) == GROwner
canDelete = isOwner || not (memberCurrent membership) canDelete = isOwner || not (memberCurrent membership)
unless canDelete $ throwChatError $ CEGroupUserRole GROwner unless canDelete $ throwChatError $ CEGroupUserRole gInfo GROwner
filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo filesInfo <- withStore' $ \db -> getGroupFileInfo db user gInfo
withChatLock "deleteChat group" . procCmd $ do withChatLock "deleteChat group" . procCmd $ do
deleteFilesAndConns user filesInfo deleteFilesAndConns user filesInfo
@ -1030,6 +1037,10 @@ processChatCommand = \case
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg deletedItemId <- getSentChatItemIdByText user chatRef deletedMsg
processChatCommand $ APIDeleteChatItem chatRef deletedItemId CIDMBroadcast processChatCommand $ APIDeleteChatItem chatRef deletedItemId CIDMBroadcast
DeleteMemberMessage gName mName deletedMsg -> withUser $ \user -> do
(gId, mId) <- getGroupAndMemberId user gName mName
deletedItemId <- withStore $ \db -> getGroupChatItemIdByText db user gId (Just mName) $ safeDecodeUtf8 deletedMsg
processChatCommand $ APIDeleteMemberChatItem gId mId deletedItemId
EditMessage chatName editedMsg msg -> withUser $ \user -> do EditMessage chatName editedMsg msg -> withUser $ \user -> do
chatRef <- getChatRef user chatName chatRef <- getChatRef user chatName
editedItemId <- getSentChatItemIdByText user chatRef editedMsg editedItemId <- getSentChatItemIdByText user chatRef editedMsg
@ -1467,10 +1478,16 @@ processChatCommand = \case
pure $ CRGroupUpdated user g g' Nothing pure $ CRGroupUpdated user g g' Nothing
assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m () assertUserGroupRole :: GroupInfo -> GroupMemberRole -> m ()
assertUserGroupRole g@GroupInfo {membership} requiredRole = do 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 (memberStatus membership == GSMemInvited) $ throwChatError (CEGroupNotJoined g)
when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved when (memberRemoved membership) $ throwChatError CEGroupMemberUserRemoved
unless (memberActive membership) $ throwChatError CEGroupMemberNotActive 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 :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse
updateGroupProfileByName gName update = withUser $ \user -> do updateGroupProfileByName gName update = withUser $ \user -> do
g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> 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 deleteDirectCI user ct ci True True >>= toView
CTGroup -> do CTGroup -> do
(gInfo, ci) <- withStore $ \db -> (,) <$> getGroupInfo db user chatId <*> getGroupChatItem db user chatId itemId (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" _ -> toView . CRChatError (Just user) . ChatError $ CEInternalError "bad deleteTimedItem cType"
startUpdatedTimedItemThread :: ChatMonad m => User -> ChatRef -> ChatItem c d -> ChatItem c d -> m () 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 case event of
XMsgNew mc -> newContentMessage ct mc msg msgMeta XMsgNew mc -> newContentMessage ct mc msg msgMeta
XMsgUpdate sharedMsgId mContent ttl live -> messageUpdate ct sharedMsgId mContent msg msgMeta ttl live 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 -- TODO discontinue XFile
XFile fInv -> processFileInvitation' ct fInv msg msgMeta XFile fInv -> processFileInvitation' ct fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancel ct sharedMsgId msgMeta XFileCancel sharedMsgId -> xFileCancel ct sharedMsgId msgMeta
@ -2356,7 +2373,7 @@ processAgentMessageConn user@User {userId} corrId agentConnId agentMessage = do
case event of case event of
XMsgNew mc -> canSend $ newGroupContentMessage gInfo m mc msg msgMeta XMsgNew mc -> canSend $ newGroupContentMessage gInfo m mc msg msgMeta
XMsgUpdate sharedMsgId mContent ttl live -> canSend $ groupMessageUpdate gInfo m sharedMsgId mContent msg msgMeta ttl live 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 -- TODO discontinue XFile
XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta XFile fInv -> processGroupFileInvitation' gInfo m fInv msg msgMeta
XFileCancel sharedMsgId -> xFileCancelGroup gInfo m sharedMsgId 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 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" (SMDSnd, _) -> messageError "x.msg.update: group member attempted invalid message update"
groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> RcvMessage -> m () groupMessageDelete :: GroupInfo -> GroupMember -> SharedMsgId -> Maybe MemberId -> RcvMessage -> m ()
groupMessageDelete gInfo@GroupInfo {groupId} GroupMember {groupMemberId, memberId} sharedMsgId RcvMessage {msgId} = do groupMessageDelete gInfo@GroupInfo {groupId, membership} m@GroupMember {memberId, memberRole = senderRole} sharedMsgId sndMemberId_ RcvMessage {msgId} = do
ci@(CChatItem msgDir ChatItem {chatDir}) <- withStore $ \db -> getGroupChatItemBySharedMsgId db user groupId groupMemberId sharedMsgId let msgMemberId = fromMaybe memberId sndMemberId_
case (msgDir, chatDir) of withStore' (\db -> runExceptT $ getGroupMemberCIBySharedMsgId db user groupId msgMemberId sharedMsgId) >>= \case
(SMDRcv, CIGroupRcv m) -> Right ci@(CChatItem _ ChatItem {chatDir}) -> case chatDir of
if sameMemberId memberId m CIGroupRcv mem
then | sameMemberId memberId mem && msgMemberId == memberId -> delete ci Nothing >>= toView
if groupFeatureAllowed SGFFullDelete gInfo | otherwise -> deleteMsg mem ci
then deleteGroupCI user gInfo ci False False >>= toView CIGroupSnd -> deleteMsg membership ci
else markGroupCIDeleted user gInfo ci msgId False >>= toView Left e -> messageError $ "x.msg.del: message not found, " <> tshow e
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 where
(SMDSnd, _) -> messageError "x.msg.del: group member attempted invalid message delete" 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 -- TODO remove once XFile is discontinued
processFileInvitation' :: Contact -> FileInvitation -> RcvMessage -> MsgMeta -> m () 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 :: GroupInfo -> GroupMember -> RcvMessage -> MsgMeta -> m ()
xGrpDel gInfo@GroupInfo {membership} m@GroupMember {memberRole} msg msgMeta = do 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 ms <- withStore' $ \db -> do
members <- getGroupMembers db user gInfo members <- getGroupMembers db user gInfo
updateGroupMemberStatus db userId membership GSMemGroupDeleted updateGroupMemberStatus db userId membership GSMemGroupDeleted
@ -3628,7 +3657,7 @@ mkChatItem cd ciId content file quotedItem sharedMsgId itemTimed live itemTs cur
tz <- getCurrentTimeZone tz <- getCurrentTimeZone
let itemText = ciContentToText content let itemText = ciContentToText content
itemStatus = ciCreateStatus 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} pure ChatItem {chatDir = toCIDirection cd, meta, content, formattedText = parseMaybeMarkdownList itemText, quotedItem, file}
deleteDirectCI :: ChatMonad m => User -> Contact -> CChatItem 'CTDirect -> Bool -> Bool -> m ChatResponse 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 withStore' $ \db -> deleteDirectChatItem db user ct ci
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) Nothing byUser timed
deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> m ChatResponse deleteGroupCI :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> Bool -> Bool -> Maybe GroupMember -> m ChatResponse
deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed = do deleteGroupCI user gInfo ci@(CChatItem msgDir deletedItem@ChatItem {file}) byUser timed byGroupMember_ = do
deleteCIFile user file deleteCIFile user file
withStore' $ \db -> deleteGroupChatItem db user gInfo ci toCi <- withStore' $ \db ->
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) Nothing byUser timed 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 :: (ChatMonad m, MsgDirectionI d) => User -> Maybe (CIFile d) -> m ()
deleteCIFile user file = 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 toCi <- withStore' $ \db -> markDirectChatItemDeleted db user ct ci msgId
pure $ CRChatItemDeleted user (AChatItem SCTDirect msgDir (DirectChat ct) deletedItem) (Just toCi) byUser False 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 :: ChatMonad m => User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> Bool -> Maybe GroupMember -> m ChatResponse
markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser = do markGroupCIDeleted user gInfo ci@(CChatItem msgDir deletedItem) msgId byUser byGroupMember_ = do
toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId toCi <- withStore' $ \db -> markGroupChatItemDeleted db user gInfo ci msgId byGroupMember_
pure $ CRChatItemDeleted user (AChatItem SCTGroup msgDir (GroupChat gInfo) deletedItem) (Just toCi) byUser False 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) 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))), "/_send " *> (APISendMessage <$> chatRefP <*> liveMessageP <*> (" json " *> jsonP <|> " text " *> (ComposedMessage Nothing Nothing <$> mcTextP))),
"/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP), "/_update item " *> (APIUpdateChatItem <$> chatRefP <* A.space <*> A.decimal <*> liveMessageP <* A.space <*> msgContentP),
"/_delete item " *> (APIDeleteChatItem <$> chatRefP <* A.space <*> A.decimal <* A.space <*> ciDeleteMode), "/_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)))), "/_read chat " *> (APIChatRead <$> chatRefP <*> optional (A.space *> ((,) <$> ("from=" *> A.decimal) <* A.space <*> ("to=" *> A.decimal)))),
"/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP), "/_unread chat " *> (APIChatUnread <$> chatRefP <* A.space <*> onOffP),
"/_delete " *> (APIDeleteChat <$> chatRefP), "/_delete " *> (APIDeleteChat <$> chatRefP),
@ -4038,6 +4071,7 @@ chatCommandP =
(">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv), (">@" <|> "> @") *> sendMsgQuote (AMsgDirection SMDRcv),
(">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd), (">>@" <|> ">> @") *> sendMsgQuote (AMsgDirection SMDSnd),
("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> A.takeByteString), ("\\ " <|> "\\") *> (DeleteMessage <$> chatNameP <* A.space <*> A.takeByteString),
("\\\\ #" <|> "\\\\#") *> (DeleteMemberMessage <$> displayName <* A.space <* char_ '@' <*> displayName <* A.space <*> A.takeByteString),
("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> A.takeByteString), ("! " <|> "!") *> (EditMessage <$> chatNameP <* A.space <*> (quotedMsg <|> pure "") <*> A.takeByteString),
"/feed " *> (SendMessageBroadcast <$> A.takeByteString), "/feed " *> (SendMessageBroadcast <$> A.takeByteString),
("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))), ("/chats" <|> "/cs") *> (LastChats <$> (" all" $> Nothing <|> Just <$> (A.space *> A.decimal <|> pure 20))),

4
src/Simplex/Chat/Controller.hs
View File

@ -203,6 +203,7 @@ data ChatCommand
| APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage} | APISendMessage {chatRef :: ChatRef, liveMessage :: Bool, composedMessage :: ComposedMessage}
| APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent} | APIUpdateChatItem {chatRef :: ChatRef, chatItemId :: ChatItemId, liveMessage :: Bool, msgContent :: MsgContent}
| APIDeleteChatItem ChatRef ChatItemId CIDeleteMode | APIDeleteChatItem ChatRef ChatItemId CIDeleteMode
| APIDeleteMemberChatItem GroupId GroupMemberId ChatItemId
| APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId)) | APIChatRead ChatRef (Maybe (ChatItemId, ChatItemId))
| APIChatUnread ChatRef Bool | APIChatUnread ChatRef Bool
| APIDeleteChat ChatRef | APIDeleteChat ChatRef
@ -297,6 +298,7 @@ data ChatCommand
| SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString} | SendMessageQuote {contactName :: ContactName, msgDir :: AMsgDirection, quotedMsg :: ByteString, message :: ByteString}
| SendMessageBroadcast ByteString -- UserId (not used in UI) | SendMessageBroadcast ByteString -- UserId (not used in UI)
| DeleteMessage ChatName ByteString | DeleteMessage ChatName ByteString
| DeleteMemberMessage GroupName ContactName ByteString
| EditMessage {chatName :: ChatName, editedMsg :: ByteString, message :: ByteString} | EditMessage {chatName :: ChatName, editedMsg :: ByteString, message :: ByteString}
| UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: ByteString} | UpdateLiveMessage {chatName :: ChatName, chatItemId :: ChatItemId, liveMessage :: Bool, message :: ByteString}
| APINewGroup UserId GroupProfile | APINewGroup UserId GroupProfile
@ -657,7 +659,7 @@ data ChatErrorType
| CEContactNotReady {contact :: Contact} | CEContactNotReady {contact :: Contact}
| CEContactDisabled {contact :: Contact} | CEContactDisabled {contact :: Contact}
| CEConnectionDisabled {connection :: Connection} | CEConnectionDisabled {connection :: Connection}
| CEGroupUserRole {requiredRole :: GroupMemberRole} | CEGroupUserRole {groupInfo :: GroupInfo, requiredRole :: GroupMemberRole}
| CEContactIncognitoCantInvite | CEContactIncognitoCantInvite
| CEGroupIncognitoCantInvite | CEGroupIncognitoCantInvite
| CEGroupContactRole {contactName :: ContactName} | CEGroupContactRole {contactName :: ContactName}

85
src/Simplex/Chat/Messages.hs
View File

@ -19,6 +19,7 @@ import qualified Data.Attoparsec.ByteString.Char8 as A
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (isNothing)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (decodeLatin1, encodeUtf8) import Data.Text.Encoding (decodeLatin1, encodeUtf8)
@ -121,7 +122,7 @@ instance ToJSON AChatInfo where
data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem data ChatItem (c :: ChatType) (d :: MsgDirection) = ChatItem
{ chatDir :: CIDirection c d, { chatDir :: CIDirection c d,
meta :: CIMeta d, meta :: CIMeta c d,
content :: CIContent d, content :: CIContent d,
formattedText :: Maybe MarkdownList, formattedText :: Maybe MarkdownList,
quotedItem :: Maybe (CIQuote c), quotedItem :: Maybe (CIQuote c),
@ -183,6 +184,26 @@ chatItemTs' ChatItem {meta = CIMeta {itemTs}} = itemTs
chatItemTimed :: ChatItem c d -> Maybe CITimed chatItemTimed :: ChatItem c d -> Maybe CITimed
chatItemTimed ChatItem {meta = CIMeta {itemTimed}} = itemTimed 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 data ChatDirection (c :: ChatType) (d :: MsgDirection) where
CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd CDDirectSnd :: Contact -> ChatDirection 'CTDirect 'MDSnd
CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv CDDirectRcv :: Contact -> ChatDirection 'CTDirect 'MDRcv
@ -277,13 +298,13 @@ instance MsgDirectionI d => ToJSON (JSONAnyChatItem c d) where
toEncoding = J.genericToEncoding J.defaultOptions toEncoding = J.genericToEncoding J.defaultOptions
-- This type is not saved to DB, so all JSON encodings are platform-specific -- 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, { itemId :: ChatItemId,
itemTs :: ChatItemTs, itemTs :: ChatItemTs,
itemText :: Text, itemText :: Text,
itemStatus :: CIStatus d, itemStatus :: CIStatus d,
itemSharedMsgId :: Maybe SharedMsgId, itemSharedMsgId :: Maybe SharedMsgId,
itemDeleted :: Bool, itemDeleted :: Maybe (CIDeleted c),
itemEdited :: Bool, itemEdited :: Bool,
itemTimed :: Maybe CITimed, itemTimed :: Maybe CITimed,
itemLive :: Maybe Bool, itemLive :: Maybe Bool,
@ -294,15 +315,15 @@ data CIMeta (d :: MsgDirection) = CIMeta
} }
deriving (Show, Generic) 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 = mkCIMeta itemId itemContent itemText itemStatus itemSharedMsgId itemDeleted itemEdited itemTimed itemLive tz currentTs itemTs createdAt updatedAt =
let localItemTs = utcToZonedTime tz itemTs let localItemTs = utcToZonedTime tz itemTs
editable = case itemContent of editable = case itemContent of
CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && not itemDeleted CISndMsgContent _ -> diffUTCTime currentTs itemTs < nominalDay && isNothing itemDeleted
_ -> False _ -> False
in CIMeta {itemId, itemTs, itemText, itemStatus, itemSharedMsgId, itemDeleted, itemEdited, itemTimed, itemLive, editable, localItemTs, createdAt, updatedAt} 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 data CITimed = CITimed
{ ttl :: Int, -- seconds { ttl :: Int, -- seconds
@ -629,6 +650,8 @@ data CIContent (d :: MsgDirection) where
CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd CISndGroupFeature :: GroupFeature -> GroupPreference -> Maybe Int -> CIContent 'MDSnd
CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv CIRcvChatFeatureRejected :: ChatFeature -> CIContent 'MDRcv
CIRcvGroupFeatureRejected :: GroupFeature -> 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 -- ^ 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 -- ! ^ Nested sum types also have to use different encodings for database and API
-- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent -- ! ^ to avoid breaking cross-platform compatibility, see RcvGroupEvent and SndGroupEvent
@ -661,6 +684,7 @@ ciRequiresAttention content = case msgDirection @d of
CIRcvGroupFeature {} -> False CIRcvGroupFeature {} -> False
CIRcvChatFeatureRejected _ -> True CIRcvChatFeatureRejected _ -> True
CIRcvGroupFeatureRejected _ -> True CIRcvGroupFeatureRejected _ -> True
CIRcvModerated -> True
ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d ciCreateStatus :: forall d. MsgDirectionI d => CIContent d -> CIStatus d
ciCreateStatus content = case msgDirection @d of ciCreateStatus content = case msgDirection @d of
@ -820,6 +844,8 @@ ciContentToText = \case
CISndGroupFeature feature pref param -> groupPrefStateText feature pref param CISndGroupFeature feature pref param -> groupPrefStateText feature pref param
CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited" CIRcvChatFeatureRejected feature -> chatFeatureNameText feature <> ": received, prohibited"
CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited" CIRcvGroupFeatureRejected feature -> groupFeatureNameText feature <> ": received, prohibited"
CISndModerated -> ciModeratedText
CIRcvModerated -> ciModeratedText
msgIntegrityError :: MsgErrorType -> Text msgIntegrityError :: MsgErrorType -> Text
msgIntegrityError = \case msgIntegrityError = \case
@ -830,10 +856,13 @@ msgIntegrityError = \case
MsgBadHash -> "incorrect message hash" MsgBadHash -> "incorrect message hash"
MsgDuplicate -> "duplicate message ID" MsgDuplicate -> "duplicate message ID"
msgDirToDeletedContent_ :: SMsgDirection d -> CIDeleteMode -> CIContent d msgDirToModeratedContent_ :: SMsgDirection d -> CIContent d
msgDirToDeletedContent_ msgDir mode = case msgDir of msgDirToModeratedContent_ = \case
SMDRcv -> CIRcvDeleted mode SMDRcv -> CIRcvModerated
SMDSnd -> CISndDeleted mode SMDSnd -> CISndModerated
ciModeratedText :: Text
ciModeratedText = "moderated"
-- platform independent -- platform independent
instance ToField (CIContent d) where instance ToField (CIContent d) where
@ -878,6 +907,8 @@ data JSONCIContent
| JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | JCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
| JCIRcvChatFeatureRejected {feature :: ChatFeature} | JCIRcvChatFeatureRejected {feature :: ChatFeature}
| JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | JCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
| JCISndModerated
| JCIRcvModerated
deriving (Generic) deriving (Generic)
instance FromJSON JSONCIContent where instance FromJSON JSONCIContent where
@ -910,6 +941,8 @@ jsonCIContent = \case
CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param} CISndGroupFeature groupFeature preference param -> JCISndGroupFeature {groupFeature, preference, param}
CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature} CIRcvChatFeatureRejected feature -> JCIRcvChatFeatureRejected {feature}
CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature} CIRcvGroupFeatureRejected groupFeature -> JCIRcvGroupFeatureRejected {groupFeature}
CISndModerated -> JCISndModerated
CIRcvModerated -> JCISndModerated
aciContentJSON :: JSONCIContent -> ACIContent aciContentJSON :: JSONCIContent -> ACIContent
aciContentJSON = \case aciContentJSON = \case
@ -934,6 +967,8 @@ aciContentJSON = \case
JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param JCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature JCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature JCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
JCISndModerated -> ACIContent SMDSnd CISndModerated
JCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
-- platform independent -- platform independent
data DBJSONCIContent data DBJSONCIContent
@ -958,6 +993,8 @@ data DBJSONCIContent
| DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int} | DBJCISndGroupFeature {groupFeature :: GroupFeature, preference :: GroupPreference, param :: Maybe Int}
| DBJCIRcvChatFeatureRejected {feature :: ChatFeature} | DBJCIRcvChatFeatureRejected {feature :: ChatFeature}
| DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature} | DBJCIRcvGroupFeatureRejected {groupFeature :: GroupFeature}
| DBJCISndModerated
| DBJCIRcvModerated
deriving (Generic) deriving (Generic)
instance FromJSON DBJSONCIContent where instance FromJSON DBJSONCIContent where
@ -990,6 +1027,8 @@ dbJsonCIContent = \case
CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param} CISndGroupFeature groupFeature preference param -> DBJCISndGroupFeature {groupFeature, preference, param}
CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature} CIRcvChatFeatureRejected feature -> DBJCIRcvChatFeatureRejected {feature}
CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature} CIRcvGroupFeatureRejected groupFeature -> DBJCIRcvGroupFeatureRejected {groupFeature}
CISndModerated -> DBJCISndModerated
CIRcvModerated -> DBJCIRcvModerated
aciContentDBJSON :: DBJSONCIContent -> ACIContent aciContentDBJSON :: DBJSONCIContent -> ACIContent
aciContentDBJSON = \case aciContentDBJSON = \case
@ -1014,6 +1053,8 @@ aciContentDBJSON = \case
DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param DBJCISndGroupFeature {groupFeature, preference, param} -> ACIContent SMDSnd $ CISndGroupFeature groupFeature preference param
DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature DBJCIRcvChatFeatureRejected {feature} -> ACIContent SMDRcv $ CIRcvChatFeatureRejected feature
DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature DBJCIRcvGroupFeatureRejected {groupFeature} -> ACIContent SMDRcv $ CIRcvGroupFeatureRejected groupFeature
DBJCISndModerated -> ACIContent SMDSnd CISndModerated
DBJCIRcvModerated -> ACIContent SMDRcv CIRcvModerated
data CICallStatus data CICallStatus
= CISCallPending = 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 checkDirection x = case testEquality (msgDirection @d) (msgDirection @d') of
Just Refl -> Right x Just Refl -> Right x
Nothing -> Left "bad direction" 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

14
src/Simplex/Chat/Migrations/M20230206_item_deleted_by_group_member_id.hs Normal file
View File

@ -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);
|]

6
src/Simplex/Chat/Migrations/chat_schema.sql
View File

@ -372,7 +372,8 @@ CREATE TABLE chat_items(
item_edited INTEGER, item_edited INTEGER,
timed_ttl INTEGER, timed_ttl INTEGER,
timed_delete_at TEXT, 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( CREATE TABLE chat_item_messages(
chat_item_id INTEGER NOT NULL REFERENCES chat_items ON DELETE CASCADE, 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) UNIQUE(user_id, host, port)
); );
CREATE INDEX idx_smp_servers_user_id ON smp_servers(user_id); 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
);

8
src/Simplex/Chat/Protocol.hs
View File

@ -180,7 +180,7 @@ instance StrEncoding AChatMessage where
data ChatMsgEvent (e :: MsgEncoding) where data ChatMsgEvent (e :: MsgEncoding) where
XMsgNew :: MsgContainer -> ChatMsgEvent 'Json XMsgNew :: MsgContainer -> ChatMsgEvent 'Json
XMsgUpdate :: {msgId :: SharedMsgId, content :: MsgContent, ttl :: Maybe Int, live :: Maybe Bool} -> 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 XMsgDeleted :: ChatMsgEvent 'Json
XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue XFile :: FileInvitation -> ChatMsgEvent 'Json -- TODO discontinue
XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol XFileAcpt :: String -> ChatMsgEvent 'Json -- direct file protocol
@ -558,7 +558,7 @@ toCMEventTag :: ChatMsgEvent e -> CMEventTag e
toCMEventTag msg = case msg of toCMEventTag msg = case msg of
XMsgNew _ -> XMsgNew_ XMsgNew _ -> XMsgNew_
XMsgUpdate {} -> XMsgUpdate_ XMsgUpdate {} -> XMsgUpdate_
XMsgDel _ -> XMsgDel_ XMsgDel {} -> XMsgDel_
XMsgDeleted -> XMsgDeleted_ XMsgDeleted -> XMsgDeleted_
XFile _ -> XFile_ XFile _ -> XFile_
XFileAcpt _ -> XFileAcpt_ XFileAcpt _ -> XFileAcpt_
@ -643,7 +643,7 @@ appJsonToCM AppMessageJson {msgId, event, params} = do
msg = \case msg = \case
XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params XMsgNew_ -> XMsgNew <$> JT.parseEither parseMsgContainer params
XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live" XMsgUpdate_ -> XMsgUpdate <$> p "msgId" <*> p "content" <*> opt "ttl" <*> opt "live"
XMsgDel_ -> XMsgDel <$> p "msgId" XMsgDel_ -> XMsgDel <$> p "msgId" <*> opt "memberId"
XMsgDeleted_ -> pure XMsgDeleted XMsgDeleted_ -> pure XMsgDeleted
XFile_ -> XFile <$> p "file" XFile_ -> XFile <$> p "file"
XFileAcpt_ -> XFileAcpt <$> p "fileName" XFileAcpt_ -> XFileAcpt <$> p "fileName"
@ -696,7 +696,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = case encoding @e of
params = \case params = \case
XMsgNew container -> msgContainerJSON container XMsgNew container -> msgContainerJSON container
XMsgUpdate msgId' content ttl live -> o $ ("ttl" .=? ttl) $ ("live" .=? live) ["msgId" .= msgId', "content" .= content] 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 XMsgDeleted -> JM.empty
XFile fileInv -> o ["file" .= fileInv] XFile fileInv -> o ["file" .= fileInv]
XFileAcpt fileName -> o ["fileName" .= fileName] XFileAcpt fileName -> o ["fileName" .= fileName]

136
src/Simplex/Chat/Store.hs
View File

@ -208,6 +208,7 @@ module Simplex.Chat.Store
getDirectChatItemByAgentMsgId, getDirectChatItemByAgentMsgId,
getGroupChatItem, getGroupChatItem,
getGroupChatItemBySharedMsgId, getGroupChatItemBySharedMsgId,
getGroupMemberCIBySharedMsgId,
getDirectChatItemIdByText, getDirectChatItemIdByText,
getGroupChatItemIdByText, getGroupChatItemIdByText,
getChatItemByFileId, getChatItemByFileId,
@ -220,6 +221,7 @@ module Simplex.Chat.Store
markDirectChatItemDeleted, markDirectChatItemDeleted,
updateGroupChatItem, updateGroupChatItem,
deleteGroupChatItem, deleteGroupChatItem,
updateGroupChatItemModerated,
markGroupChatItemDeleted, markGroupChatItemDeleted,
updateDirectChatItemsRead, updateDirectChatItemsRead,
getDirectUnreadTimedItems, 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.M20230117_fkey_indexes
import Simplex.Chat.Migrations.M20230118_recreate_smp_servers import Simplex.Chat.Migrations.M20230118_recreate_smp_servers
import Simplex.Chat.Migrations.M20230129_drop_chat_items_group_idx 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.Protocol
import Simplex.Chat.Types import Simplex.Chat.Types
import Simplex.Chat.Util (week) import Simplex.Chat.Util (week)
@ -402,7 +405,8 @@ schemaMigrations =
("20230111_users_agent_user_id", m20230111_users_agent_user_id), ("20230111_users_agent_user_id", m20230111_users_agent_user_id),
("20230117_fkey_indexes", m20230117_fkey_indexes), ("20230117_fkey_indexes", m20230117_fkey_indexes),
("20230118_recreate_smp_servers", m20230118_recreate_smp_servers), ("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 -- | The list of migrations in ascending order by date
@ -3511,7 +3515,11 @@ getGroupChatPreviews_ db User {userId, userContactId} = do
-- quoted GroupMember -- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, 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, 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 FROM groups g
JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id
JOIN group_members mu ON mu.group_id = g.group_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 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 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 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 = ? WHERE g.user_id = ? AND mu.contact_id = ?
ORDER BY i.item_ts DESC 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_ :: forall d. MsgDirectionI d => DB.Connection -> UserId -> Int64 -> ChatItem 'CTDirect d -> Maybe MessageId -> IO ()
updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do updateDirectChatItem_ db userId contactId ChatItem {meta, content} msgId_ = do
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta
itemDeleted' = isJust itemDeleted
DB.execute DB.execute
db db
[sql| [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 = ? 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 = ? 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 forM_ msgId_ $ \msgId -> liftIO $ insertChatItemMessage_ db itemId msgId updatedAt
deleteDirectChatItem :: DB.Connection -> User -> Contact -> CChatItem 'CTDirect -> IO () 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 = ? WHERE user_id = ? AND contact_id = ? AND chat_item_id = ?
|] |]
(currentTs, userId, contactId, itemId) (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.Connection -> User -> ContactId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTDirect)
getDirectChatItemBySharedMsgId db user@User {userId} contactId sharedMsgId = do 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_ :: forall d. MsgDirectionI d => DB.Connection -> User -> Int64 -> ChatItem 'CTGroup d -> Maybe MessageId -> IO ()
updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do updateGroupChatItem_ db User {userId} groupId ChatItem {content, meta} msgId_ = do
let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta let CIMeta {itemId, itemText, itemStatus, itemDeleted, itemEdited, itemTimed, itemLive, updatedAt} = meta
itemDeleted' = isJust itemDeleted
DB.execute DB.execute
db db
[sql| [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 = ? 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 = ? 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 forM_ msgId_ $ \msgId -> insertChatItemMessage_ db itemId msgId updatedAt
deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO () deleteGroupChatItem :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> IO ()
@ -4148,20 +4160,41 @@ deleteGroupChatItem db User {userId} GroupInfo {groupId} (CChatItem _ ci) = do
|] |]
(userId, groupId, itemId) (userId, groupId, itemId)
markGroupChatItemDeleted :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> MessageId -> IO AChatItem updateGroupChatItemModerated :: DB.Connection -> User -> GroupInfo -> CChatItem 'CTGroup -> GroupMember -> IO AChatItem
markGroupChatItemDeleted db User {userId} gInfo@GroupInfo {groupId} (CChatItem msgDir ci) msgId = do 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 currentTs <- liftIO getCurrentTime
let itemId = chatItemId' ci let itemId = chatItemId' ci
(deletedByGroupMemberId, ciDeleted) = case byGroupMember_ of
Just m@GroupMember {groupMemberId} -> (Just groupMemberId, CIModerated m)
_ -> (Nothing, CIDeleted)
insertChatItemMessage_ db itemId msgId currentTs insertChatItemMessage_ db itemId msgId currentTs
DB.execute DB.execute
db db
[sql| [sql|
UPDATE chat_items 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 = ? WHERE user_id = ? AND group_id = ? AND chat_item_id = ?
|] |]
(currentTs, userId, groupId, itemId) (deletedByGroupMemberId, currentTs, userId, groupId, itemId)
pure $ AChatItem SCTGroup msgDir (GroupChat gInfo) (ci {meta = (meta ci) {itemDeleted = True, editable = False}}) 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.Connection -> User -> GroupId -> GroupMemberId -> SharedMsgId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId sharedMsgId = do
@ -4170,15 +4203,34 @@ getGroupChatItemBySharedMsgId db user@User {userId} groupId groupMemberId shared
DB.query DB.query
db db
[sql| [sql|
SELECT chat_item_id SELECT chat_item_id
FROM chat_items FROM chat_items
WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ? WHERE user_id = ? AND group_id = ? AND group_member_id = ? AND shared_msg_id = ?
ORDER BY chat_item_id DESC ORDER BY chat_item_id DESC
LIMIT 1 LIMIT 1
|] |]
(userId, groupId, groupMemberId, sharedMsgId) (userId, groupId, groupMemberId, sharedMsgId)
getGroupChatItem db user groupId itemId 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.Connection -> User -> Int64 -> ChatItemId -> ExceptT StoreError IO (CChatItem 'CTGroup)
getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
tz <- getCurrentTimeZone tz <- getCurrentTimeZone
@ -4203,7 +4255,11 @@ getGroupChatItem db User {userId, userContactId} groupId itemId = ExceptT $ do
-- quoted GroupMember -- quoted GroupMember
rm.group_member_id, rm.group_id, rm.member_id, rm.member_role, rm.member_category, 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, 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 FROM chat_items i
LEFT JOIN files f ON f.chat_item_id = i.chat_item_id 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 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 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 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 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 = ? WHERE i.user_id = ? AND i.group_id = ? AND i.chat_item_id = ?
|] |]
(userId, groupId, itemId) (userId, groupId, itemId)
@ -4482,8 +4540,11 @@ toDirectChatItem tz currentTs (((itemId, itemTs, itemContent, itemText, itemStat
cItem d chatDir ciStatus content file = cItem d chatDir ciStatus content file =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file} CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toDirectQuote quoteRow, file}
badItem = Left $ SEBadChatItem itemId badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta d ciMeta :: CIContent d -> CIStatus d -> CIMeta 'CTDirect d
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt 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 :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
@ -4494,7 +4555,7 @@ toDirectChatItemList _ _ _ = []
type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow type GroupQuoteRow = QuoteRow :. MaybeGroupMemberRow
type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow type MaybeGroupChatItemRow = MaybeChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow :. MaybeGroupMemberRow
toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup) toGroupQuote :: QuoteRow -> Maybe GroupMember -> Maybe (CIQuote 'CTGroup)
toGroupQuote qr@(_, _, _, _, quotedSent) quotedMember_ = toQuote qr $ direction quotedSent quotedMember_ 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 (Just False) Nothing = Just $ CIQGroupRcv Nothing
direction _ _ = Nothing direction _ _ = Nothing
toGroupChatItem :: TimeZone -> UTCTime -> Int64 -> ChatItemRow :. MaybeGroupMemberRow :. GroupQuoteRow -> Either StoreError (CChatItem 'CTGroup) 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_) = do 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 member_ = toMaybeGroupMember userContactId memberRow_
let quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_ quotedMember_ = toMaybeGroupMember userContactId quotedMemberRow_
deletedByGroupMember_ = toMaybeGroupMember userContactId deletedByGroupMemberRow_
case (itemContent, itemStatus, member_, fileStatus_) of case (itemContent, itemStatus, member_, fileStatus_) of
(ACIContent SMDSnd ciContent, ACIStatus SMDSnd ciStatus, _, Just (AFS SMDSnd fileStatus)) -> (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) -> (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)) -> (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) -> (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 _ -> badItem
where where
maybeCIFile :: CIFileStatus d -> Maybe (CIFile d) maybeCIFile :: CIFileStatus d -> Maybe (CIFile d)
@ -4524,18 +4586,24 @@ toGroupChatItem tz currentTs userContactId (((itemId, itemTs, itemContent, itemT
case (fileId_, fileName_, fileSize_) of case (fileId_, fileName_, fileSize_) of
(Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus} (Just fileId, Just fileName, Just fileSize) -> Just CIFile {fileId, fileName, fileSize, filePath, fileStatus}
_ -> Nothing _ -> Nothing
cItem :: MsgDirectionI d => SMsgDirection d -> CIDirection 'CTGroup d -> CIStatus d -> CIContent d -> Maybe GroupMember -> Maybe (CIFile d) -> CChatItem 'CTGroup 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 = cItem d chatDir ciStatus content quotedMember_ file deletedByGroupMember_ =
CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file} CChatItem d ChatItem {chatDir, meta = ciMeta content ciStatus deletedByGroupMember_, content, formattedText = parseMaybeMarkdownList itemText, quotedItem = toGroupQuote quoteRow quotedMember_, file}
badItem = Left $ SEBadChatItem itemId badItem = Left $ SEBadChatItem itemId
ciMeta :: CIContent d -> CIStatus d -> CIMeta d ciMeta :: CIContent d -> CIStatus d -> Maybe GroupMember -> CIMeta 'CTGroup d
ciMeta content status = mkCIMeta itemId content itemText status sharedMsgId itemDeleted (fromMaybe False itemEdited) ciTimed itemLive tz currentTs itemTs createdAt updatedAt 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 :: Maybe CITimed
ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt} ciTimed = timedTTL >>= \ttl -> Just CITimed {ttl, deleteAt = timedDeleteAt}
toGroupChatItemList :: TimeZone -> UTCTime -> Int64 -> MaybeGroupChatItemRow -> [CChatItem 'CTGroup] 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_) = 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_) 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 _ _ _ _ = [] toGroupChatItemList _ _ _ _ = []
getSMPServers :: DB.Connection -> User -> IO [ServerCfg] getSMPServers :: DB.Connection -> User -> IO [ServerCfg]

85
src/Simplex/Chat/View.hs
View File

@ -19,7 +19,7 @@ import Data.Function (on)
import Data.Int (Int64) import Data.Int (Int64)
import Data.List (groupBy, intercalate, intersperse, partition, sortOn) import Data.List (groupBy, intercalate, intersperse, partition, sortOn)
import qualified Data.List.NonEmpty as L 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 Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Clock (DiffTime, UTCTime) 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] CRChatItemId u itemId -> ttyUser u [plain $ maybe "no item" show itemId]
CRChatItemStatusUpdated u _ -> ttyUser u [] CRChatItemStatusUpdated u _ -> ttyUser u []
CRChatItemUpdated u (AChatItem _ _ chat item) -> ttyUser u $ unmuted chat item $ viewItemUpdate chat item liveItems ts 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]"] 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 CRBroadcastSent u mc n t -> ttyUser u $ viewSentBroadcast mc n ts t
CRMsgIntegrityError u mErr -> ttyUser u $ viewMsgIntegrityError mErr 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 Just CIFile {filePath = Just fp} -> Just fp
_ -> Nothing _ -> Nothing
testViewItem :: CChatItem c -> Text 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 :: [a] -> StyledString -> [StyledString]
viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)] viewErrorsSummary summary s = [ttyError (T.pack . show $ length summary) <> s <> " (run with -c option to show each error)" | not (null summary)]
contactList :: [ContactRef] -> String contactList :: [ContactRef] -> String
@ -276,6 +276,15 @@ responseToView user_ ChatConfig {logLevel, testView} liveItems ts = \case
| muted chat chatItem = [] | muted chat chatItem = []
| otherwise = s | 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 :: [UserInfo] -> [StyledString]
viewUsersList = map userInfo . sortOn ldn viewUsersList = map userInfo . sortOn ldn
where 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 :: 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 withItemDeleted <$> case chat of
DirectChat c -> case chatDir of DirectChat c -> case chatDir of
CIDirectSnd -> case content of CIDirectSnd -> case content of
@ -352,7 +361,7 @@ viewChatItem chat ChatItem {chatDir, meta = meta@CIMeta {itemDeleted}, content,
quote = maybe [] (groupQuote g) quotedItem quote = maybe [] (groupQuote g) quotedItem
_ -> [] _ -> []
where 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 withSndFile = withFile viewSentFileInvitation
withRcvFile = withFile viewReceivedFileInvitation withRcvFile = withFile viewReceivedFileInvitation
withFile view dir l = maybe l (\f -> l <> view dir f ts meta) file 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 quote = maybe [] (groupQuote g) quotedItem
_ -> [] _ -> []
hideLive :: CIMeta d -> [StyledString] -> [StyledString] hideLive :: CIMeta с d -> [StyledString] -> [StyledString]
hideLive CIMeta {itemLive = Just True} _ = [] hideLive CIMeta {itemLive = Just True} _ = []
hideLive _ s = s hideLive _ s = s
viewItemDelete :: ChatInfo c -> ChatItem c d -> Bool -> Bool -> Bool -> CurrentTime -> [StyledString] viewItemDelete :: ChatInfo c -> ChatItem c d -> Maybe AChatItem -> Bool -> Bool -> CurrentTime -> Bool -> [StyledString]
viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} markedDeleted byUser timed ts viewItemDelete chat ChatItem {chatDir, meta, content = deletedContent} toItem byUser timed ts testView
| timed = [] | timed = [plain ("timed message deleted: " <> T.unpack (ciContentToText deletedContent)) | testView]
| byUser = if markedDeleted then ["message marked deleted"] else ["message deleted"] | byUser = [plain $ "message " <> T.unpack (fromMaybe "deleted" deletedText_)] -- deletedText_ Nothing should be impossible here
| otherwise = case chat of | otherwise = case chat of
DirectChat c -> case (chatDir, deletedContent) 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 _ -> prohibited
GroupChat g -> case (chatDir, deletedContent) of GroupChat g@GroupInfo {membership} -> case (chatDir, deletedContent) of
(CIGroupRcv m, CIRcvMsgContent mc) -> viewReceivedMessage (ttyFromGroupDeleted g m markedDeleted) [] mc ts meta (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
_ -> prohibited _ -> prohibited
where 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)] prohibited = [styled (colored Red) ("[unexpected message deletion, please report to developers]" :: String)]
directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString] directQuote :: forall d'. MsgDirectionI d' => CIDirection 'CTDirect d' -> CIQuote 'CTDirect -> [StyledString]
@ -445,7 +459,7 @@ msgPreview = msgPlain . preview . msgContentText
| T.length t <= 120 = t | T.length t <= 120 = t
| otherwise = T.take 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 viewRcvIntegrityError from msgErr ts meta = receivedWithTime_ ts from [] meta (viewMsgIntegrityError msgErr) False
viewMsgIntegrityError :: MsgErrorType -> [StyledString] viewMsgIntegrityError :: MsgErrorType -> [StyledString]
@ -929,22 +943,22 @@ viewContactUpdated
where where
fullNameUpdate = if T.null fullName' || fullName' == n' then " removed full name" else " updated full name: " <> plain fullName' 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 viewReceivedMessage = viewReceivedMessage_ False
viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta d -> [StyledString] viewReceivedUpdatedMessage :: StyledString -> [StyledString] -> MsgContent -> CurrentTime -> CIMeta c d -> [StyledString]
viewReceivedUpdatedMessage = viewReceivedMessage_ True 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 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 receivedWithTime_ ts from quote CIMeta {localItemTs, itemId, itemEdited, itemDeleted, itemLive} styledMsg updated = do
prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg) prependFirst (ttyMsgTime ts localItemTs <> " " <> from) (quote <> prependFirst (indent <> live) styledMsg)
where where
indent = if null quote then "" else " " indent = if null quote then "" else " "
live live
| itemEdited || itemDeleted = "" | itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of | otherwise = case itemLive of
Just True Just True
| updated -> ttyFrom "[LIVE] " | updated -> ttyFrom "[LIVE] "
@ -963,12 +977,12 @@ ttyMsgTime ts t =
else "%H:%M" else "%H:%M"
in styleTime $ formatTime defaultTimeLocale fmt localTime 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 viewSentMessage to quote mc ts meta@CIMeta {itemEdited, itemDeleted, itemLive} = sentWithTime_ ts (prependFirst to $ quote <> prependFirst (indent <> live) (ttyMsgContent mc)) meta
where where
indent = if null quote then "" else " " indent = if null quote then "" else " "
live live
| itemEdited || itemDeleted = "" | itemEdited || isJust itemDeleted = ""
| otherwise = case itemLive of | otherwise = case itemLive of
Just True -> ttyTo "[LIVE started] " Just True -> ttyTo "[LIVE started] "
Just False -> ttyTo "[LIVE] " 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 :: MsgContent -> Int -> CurrentTime -> ZonedTime -> [StyledString]
viewSentBroadcast mc n ts t = prependFirst (highlight' "/feed" <> " (" <> sShow n <> ") " <> ttyMsgTime ts t <> " ") (ttyMsgContent mc) 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 viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePath of
Just fPath -> sentWithTime_ ts $ ttySentFile fPath Just fPath -> sentWithTime_ ts $ ttySentFile fPath
_ -> const [] _ -> const []
@ -987,7 +1001,7 @@ viewSentFileInvitation to CIFile {fileId, filePath, fileStatus} ts = case filePa
CIFSSndTransfer -> [] CIFSSndTransfer -> []
_ -> ["use " <> highlight ("/fc " <> show fileId) <> " to cancel sending"] _ -> ["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} = sentWithTime_ ts styledMsg CIMeta {localItemTs} =
prependFirst (ttyMsgTime ts localItemTs <> " ") styledMsg prependFirst (ttyMsgTime ts localItemTs <> " ") styledMsg
@ -1018,7 +1032,7 @@ sendingFile_ status ft@SndFileTransfer {recipientDisplayName = c} =
sndFile :: SndFileTransfer -> StyledString sndFile :: SndFileTransfer -> StyledString
sndFile SndFileTransfer {fileId, fileName} = fileTransferStr fileId fileName 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 viewReceivedFileInvitation from file ts meta = receivedWithTime_ ts from [] meta (receivedFileInvitation_ file) False
receivedFileInvitation_ :: CIFile d -> [StyledString] 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] CEConnectionDisabled Connection {connId, connType} -> [plain $ "connection " <> textEncode connType <> " (" <> tshow connId <> ") is disabled" | logLevel <= CLLWarning]
CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"] CEGroupDuplicateMember c -> ["contact " <> ttyContact c <> " is already in the group"]
CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"] CEGroupDuplicateMemberId -> ["cannot add member - duplicate member ID"]
CEGroupUserRole role -> case role of CEGroupUserRole g role ->
GRAuthor -> ["you don't have permission to send messages to this group"] (: []) . (ttyGroup' g <>) $ case role of
_ -> ["you have insufficient permissions for this action, the required role is " <> plain (strEncode role)] 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"] 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"] 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"] 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 :: Contact -> StyledString
ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ") ttyFromContactEdited ct@Contact {localDisplayName = c} = ctIncognito ct <> ttyFrom (c <> "> [edited] ")
ttyFromContactDeleted :: Contact -> Bool -> StyledString ttyFromContactDeleted :: Contact -> Maybe Text -> StyledString
ttyFromContactDeleted ct@Contact {localDisplayName = c} markedDeleted = ttyFromContactDeleted ct@Contact {localDisplayName = c} deletedText_ =
ctIncognito ct <> ttyFrom (c <> "> " <> deleted) ctIncognito ct <> ttyFrom (c <> "> " <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
where
deleted = if markedDeleted then "[marked deleted] " else "[deleted] "
ttyGroup :: GroupName -> StyledString ttyGroup :: GroupName -> StyledString
ttyGroup g = styled (colored Blue) $ "#" <> g ttyGroup g = styled (colored Blue) $ "#" <> g
@ -1383,11 +1396,9 @@ ttyFromGroup g m = membershipIncognito g <> ttyFrom (fromGroup_ g m)
ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString ttyFromGroupEdited :: GroupInfo -> GroupMember -> StyledString
ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ") ttyFromGroupEdited g m = membershipIncognito g <> ttyFrom (fromGroup_ g m <> "[edited] ")
ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Bool -> StyledString ttyFromGroupDeleted :: GroupInfo -> GroupMember -> Maybe Text -> StyledString
ttyFromGroupDeleted g m markedDeleted = ttyFromGroupDeleted g m deletedText_ =
membershipIncognito g <> ttyFrom (fromGroup_ g m <> deleted) membershipIncognito g <> ttyFrom (fromGroup_ g m <> maybe "" (\t -> "[" <> t <> "] ") deletedText_)
where
deleted = if markedDeleted then "[marked deleted] " else "[deleted] "
fromGroup_ :: GroupInfo -> GroupMember -> Text fromGroup_ :: GroupInfo -> GroupMember -> Text
fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} = fromGroup_ GroupInfo {localDisplayName = g} GroupMember {localDisplayName = m} =

20
tests/ChatTests/Direct.hs
View File

@ -1388,6 +1388,11 @@ testUsersTimedMessages tmp = do
threadDelay 1000000 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" alice ##> "/user alice"
showActiveUser alice "alice (Alice)" showActiveUser alice "alice (Alice)"
alice #$> ("/_get chat @2 count=100", chat, []) alice #$> ("/_get chat @2 count=100", chat, [])
@ -1398,6 +1403,11 @@ testUsersTimedMessages tmp = do
threadDelay 1000000 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" alice ##> "/user"
showActiveUser alice "alisa" showActiveUser alice "alisa"
alice #$> ("/_get chat @4 count=100", chat, []) alice #$> ("/_get chat @4 count=100", chat, [])
@ -1435,6 +1445,11 @@ testUsersTimedMessages tmp = do
-- messages are deleted after restart -- messages are deleted after restart
threadDelay 1000000 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" alice ##> "/user alice"
showActiveUser alice "alice (Alice)" showActiveUser alice "alice (Alice)"
alice #$> ("/_get chat @2 count=100", chat, []) alice #$> ("/_get chat @2 count=100", chat, [])
@ -1445,6 +1460,11 @@ testUsersTimedMessages tmp = do
threadDelay 1000000 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" alice ##> "/user"
showActiveUser alice "alisa" showActiveUser alice "alisa"
alice #$> ("/_get chat @4 count=100", chat, []) alice #$> ("/_get chat @4 count=100", chat, [])

83
tests/ChatTests/Groups.hs
View File

@ -35,6 +35,8 @@ chatGroupTests = do
it "update member role" testUpdateMemberRole it "update member role" testUpdateMemberRole
it "unused contacts are deleted after all their groups are deleted" testGroupDeleteUnusedContacts 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 "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 describe "async group connections" $ do
xit "create and join group when clients go offline" testGroupAsync xit "create and join group when clients go offline" testGroupAsync
describe "group links" $ do 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" -- cath <## "#team: alice changed the role of bob from admin to observer"
-- ] -- ]
-- bob ##> "#team hello" -- 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 ##> "/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" -- cath #> "#team hello"
-- concurrentlyN_ -- concurrentlyN_
-- [ alice <# "#team cath> hello", -- [ alice <# "#team cath> hello",
@ -981,7 +983,7 @@ testUpdateGroupProfile =
(bob <# "#team alice> hello!") (bob <# "#team alice> hello!")
(cath <# "#team alice> hello!") (cath <# "#team alice> hello!")
bob ##> "/gp team my_team" 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 ##> "/gp team my_team"
alice <## "changed to #my_team" alice <## "changed to #my_team"
concurrentlyN_ concurrentlyN_
@ -1016,13 +1018,13 @@ testUpdateMemberRole =
(bob <## "#team: you joined the group") (bob <## "#team: you joined the group")
connectUsers bob cath connectUsers bob cath
bob ##> "/a team 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" alice ##> "/mr team bob admin"
concurrently_ concurrently_
(alice <## "#team: you changed the role of bob from member to admin") (alice <## "#team: you changed the role of bob from member to admin")
(bob <## "#team: alice changed your role from member to admin") (bob <## "#team: alice changed your role from member to admin")
bob ##> "/a team cath owner" 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 addMember "team" bob cath GRMember
cath ##> "/j team" cath ##> "/j team"
concurrentlyN_ concurrentlyN_
@ -1041,7 +1043,7 @@ testUpdateMemberRole =
cath <## "#team: alice changed the role from owner to admin" cath <## "#team: alice changed the role from owner to admin"
] ]
alice ##> "/d #team" 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 :: HasCallStack => FilePath -> IO ()
testGroupDeleteUnusedContacts = testGroupDeleteUnusedContacts =
@ -1195,6 +1197,75 @@ testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile
cc <## "#team: bob added dan (Daniel) to the group (connecting...)" cc <## "#team: bob added dan (Daniel) to the group (connecting...)"
cc <## "#team: new member dan is connected" 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 :: HasCallStack => FilePath -> IO ()
testGroupAsync tmp = do testGroupAsync tmp = do
print (0 :: Integer) print (0 :: Integer)

10
tests/ChatTests/Profiles.hs
View File

@ -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")]) 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")]) 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 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)")]) 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)")]) 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 -- 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")]) 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")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)"), (0, "hi")])
threadDelay 1000000 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)")]) 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)")]) bob #$> ("/_get chat #1 count=100", chat, groupFeatures <> [(0, "connected"), (0, "Disappearing messages: on (1 sec)")])
-- turn off, messages are not disappearing -- 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")]) 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")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)"), (0, "hi"), (1, "hey")])
threadDelay 1000000 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)")]) 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)")]) bob #$> ("/_get chat @2 count=100", chat, chatFeatures <> [(1, "Disappearing messages: enabled (1 sec)")])

2
tests/ProtocolTests.hs
View File

@ -171,7 +171,7 @@ decodeChatMessageTest = describe "Chat message encoding/decoding" $ do
#==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing #==# XMsgUpdate (SharedMsgId "\1\2\3\4") (MCText "hello") Nothing Nothing
it "x.msg.del" $ it "x.msg.del" $
"{\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}" "{\"event\":\"x.msg.del\",\"params\":{\"msgId\":\"AQIDBA==\"}}"
#==# XMsgDel (SharedMsgId "\1\2\3\4") #==# XMsgDel (SharedMsgId "\1\2\3\4") Nothing
it "x.msg.deleted" $ it "x.msg.deleted" $
"{\"event\":\"x.msg.deleted\",\"params\":{}}" "{\"event\":\"x.msg.deleted\",\"params\":{}}"
#==# XMsgDeleted #==# XMsgDeleted