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

core: editing group profiles (no conflict resolution) (#851)

Browse Source 
* core: editing group profiles with conflict resolution

* update group profiles

* fix group update

* add test, add group profile to chat items, update terminal output

* Update apps/android/.idea/gradle.xml
This commit is contained in:
Evgeny Poberezkin
2022-07-29 19:04:32 +01:00
committed by GitHub
parent e87c78e997
commit 0c58adff08
8 changed files with 115 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

27
src/Simplex/Chat.hs
View File

@@ -791,6 +791,21 @@ processChatCommand = \case
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIListMembers groupId
ListGroups -> CRGroupsList <$> withUser (\user -> withStore' (`getUserGroupDetails` user))
APIUpdateGroupProfile groupId p' -> withUser $ \user -> do
Group g ms <- withStore $ \db -> getGroup db user groupId
let s = memberStatus $ membership g
canUpdate =
memberRole (membership g :: GroupMember) == GROwner
|| (s == GSMemRemoved || s == GSMemLeft || s == GSMemGroupDeleted || s == GSMemInvited)
unless canUpdate $ throwChatError CEGroupUserRole
g' <- withStore $ \db -> updateGroupProfile db user g p'
msg <- sendGroupMessage g' ms (XGrpInfo p')
ci <- saveSndChatItem user (CDGroupSnd g') msg (CISndGroupEvent $ SGEGroupUpdated p') Nothing Nothing
toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci
pure $ CRGroupUpdated g g' Nothing
UpdateGroupProfile gName profile -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
processChatCommand $ APIUpdateGroupProfile groupId profile
SendGroupMessageQuote gName cName quotedMsg msg -> withUser $ \user -> do
groupId <- withStore $ \db -> getGroupIdByName db user gName
quotedItemId <- withStore $ \db -> getGroupChatItemIdByText db user groupId cName (safeDecodeUtf8 quotedMsg)
@@ -1451,6 +1466,7 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
XGrpMemDel memId -> xGrpMemDel gInfo m memId msg msgMeta
XGrpLeave -> xGrpLeave gInfo m msg msgMeta
XGrpDel -> xGrpDel gInfo m msg msgMeta
XGrpInfo p' -> xGrpInfo gInfo m p' msg msgMeta
_ -> messageError $ "unsupported message: " <> T.pack (show chatMsgEvent)
ackMsgDeliveryEvent conn msgMeta
SENT msgId ->
@@ -2067,6 +2083,15 @@ processAgentMessage (Just user@User {userId, profile}) agentConnId agentMessage
groupMsgToView gInfo m ci msgMeta
toView $ CRGroupDeleted gInfo {membership = membership {memberStatus = GSMemGroupDeleted}} m
xGrpInfo :: GroupInfo -> GroupMember -> GroupProfile -> RcvMessage -> MsgMeta -> m ()
xGrpInfo g m@GroupMember {memberRole} p' msg msgMeta
| memberRole < GROwner = messageError "x.grp.info with insufficient member permissions"
| otherwise = do
g' <- withStore $ \db -> updateGroupProfile db user g p'
ci <- saveRcvChatItem user (CDGroupRcv g' m) msg msgMeta (CIRcvGroupEvent $ RGEGroupUpdated p') Nothing
groupMsgToView g' m ci msgMeta
toView . CRGroupUpdated g g' $ Just m
parseChatMessage :: ByteString -> Either ChatError ChatMessage
parseChatMessage = first (ChatError . CEInvalidChatMessage) . strDecode
@@ -2482,6 +2507,8 @@ chatCommandP =
("/clear @" <|> "/clear ") *> (ClearContact <$> displayName),
("/members #" <|> "/members " <|> "/ms #" <|> "/ms ") *> (ListMembers <$> displayName),
("/groups" <|> "/gs") $> ListGroups,
"/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP),
("/group_profile #" <|> "/gp #" <|> "/group_profile " <|> "/gp ") *> (UpdateGroupProfile <$> displayName <* A.space <*> groupProfile),
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <*> pure Nothing <*> quotedMsg <*> A.takeByteString),
(">#" <|> "> #") *> (SendGroupMessageQuote <$> displayName <* A.space <* optional (A.char '@') <*> (Just <$> displayName) <* A.space <*> quotedMsg <*> A.takeByteString),
("/contacts" <|> "/cs") $> ListContacts,

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

@@ -141,6 +141,7 @@ data ChatCommand
| APIRemoveMember GroupId GroupMemberId
| APILeaveGroup GroupId
| APIListMembers GroupId
| APIUpdateGroupProfile GroupId GroupProfile
| GetUserSMPServers
| SetUserSMPServers [SMPServer]
| APISetNetworkConfig NetworkConfig
@@ -178,6 +179,7 @@ data ChatCommand
| ClearGroup GroupName
| ListMembers GroupName
| ListGroups
| UpdateGroupProfile GroupName GroupProfile
| SendGroupMessageQuote {groupName :: GroupName, contactName_ :: Maybe ContactName, quotedMsg :: ByteString, message :: ByteString}
| LastMessages (Maybe ChatName) Int
| SendFile ChatName FilePath
@@ -279,6 +281,7 @@ data ChatResponse
| CRGroupEmpty {groupInfo :: GroupInfo}
| CRGroupRemoved {groupInfo :: GroupInfo}
| CRGroupDeleted {groupInfo :: GroupInfo, member :: GroupMember}
| CRGroupUpdated {fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember}
| CRMemberSubError {groupInfo :: GroupInfo, member :: GroupMember, chatError :: ChatError}
| CRMemberSubSummary {memberSubscriptions :: [MemberSubStatus]}
| CRGroupSubscribed {groupInfo :: GroupInfo}

1
src/Simplex/Chat/Help.hs
View File

@@ -123,6 +123,7 @@ groupsHelpInfo =
indent <> highlight "/leave <group> " <> " - leave group",
indent <> highlight "/delete <group> " <> " - delete group",
indent <> highlight "/members <group> " <> " - list group members",
indent <> highlight "/gp <group> <new_name> [<full_name>] " <> " - update group profile",
indent <> highlight "/groups " <> " - list groups",
indent <> highlight "#<group> <message> " <> " - send message to group",
"",

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

@@ -507,11 +507,13 @@ rcvGroupEventToText = \case
RGEMemberDeleted _ p -> "removed " <> memberProfileToText p
RGEUserDeleted -> "removed you"
RGEGroupDeleted -> "deleted group"
RGEGroupUpdated _ -> "group profile updated"
sndGroupEventToText :: SndGroupEvent -> Text
sndGroupEventToText = \case
SGEMemberDeleted _ p -> "removed " <> memberProfileToText p
SGEUserLeft -> "left"
SGEGroupUpdated _ -> "group profile updated"
memberProfileToText :: Profile -> Text
memberProfileToText Profile {displayName, fullName} = displayName <> optionalFullName displayName fullName
@@ -539,6 +541,7 @@ data RcvGroupEvent
| RGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRDeletedMember
| RGEUserDeleted -- CRDeletedMemberUser
| RGEGroupDeleted -- CRGroupDeleted
| RGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
deriving (Show, Generic)
instance FromJSON RcvGroupEvent where
@@ -551,6 +554,7 @@ instance ToJSON RcvGroupEvent where
data SndGroupEvent
= SGEMemberDeleted {groupMemberId :: GroupMemberId, profile :: Profile} -- CRUserDeletedMember
| SGEUserLeft -- CRLeftMemberUser
| SGEGroupUpdated {groupProfile :: GroupProfile} -- CRGroupUpdated
deriving (Show, Generic)
instance FromJSON SndGroupEvent where

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

@@ -135,6 +135,7 @@ data ChatMsgEvent
| XGrpMemDel MemberId
| XGrpLeave
| XGrpDel
| XGrpInfo GroupProfile
| XInfoProbe Probe
| XInfoProbeCheck ProbeHash
| XInfoProbeOk Probe
@@ -315,6 +316,7 @@ data CMEventTag
| XGrpMemDel_
| XGrpLeave_
| XGrpDel_
| XGrpInfo_
| XInfoProbe_
| XInfoProbeCheck_
| XInfoProbeOk_
@@ -351,6 +353,7 @@ instance StrEncoding CMEventTag where
XGrpMemDel_ -> "x.grp.mem.del"
XGrpLeave_ -> "x.grp.leave"
XGrpDel_ -> "x.grp.del"
XGrpInfo_ -> "x.grp.info"
XInfoProbe_ -> "x.info.probe"
XInfoProbeCheck_ -> "x.info.probe.check"
XInfoProbeOk_ -> "x.info.probe.ok"
@@ -384,6 +387,7 @@ instance StrEncoding CMEventTag where
"x.grp.mem.del" -> Right XGrpMemDel_
"x.grp.leave" -> Right XGrpLeave_
"x.grp.del" -> Right XGrpDel_
"x.grp.info" -> Right XGrpInfo_
"x.info.probe" -> Right XInfoProbe_
"x.info.probe.check" -> Right XInfoProbeCheck_
"x.info.probe.ok" -> Right XInfoProbeOk_
@@ -420,6 +424,7 @@ toCMEventTag = \case
XGrpMemDel _ -> XGrpMemDel_
XGrpLeave -> XGrpLeave_
XGrpDel -> XGrpDel_
XGrpInfo _ -> XGrpInfo_
XInfoProbe _ -> XInfoProbe_
XInfoProbeCheck _ -> XInfoProbeCheck_
XInfoProbeOk _ -> XInfoProbeOk_
@@ -484,6 +489,7 @@ appToChatMessage AppMessage {msgId, event, params} = do
XGrpMemDel_ -> XGrpMemDel <$> p "memberId"
XGrpLeave_ -> pure XGrpLeave
XGrpDel_ -> pure XGrpDel
XGrpInfo_ -> XGrpInfo <$> p "groupProfile"
XInfoProbe_ -> XInfoProbe <$> p "probe"
XInfoProbeCheck_ -> XInfoProbeCheck <$> p "probeHash"
XInfoProbeOk_ -> XInfoProbeOk <$> p "probe"
@@ -525,6 +531,7 @@ chatToAppMessage ChatMessage {msgId, chatMsgEvent} = AppMessage {msgId, event, p
XGrpMemDel memId -> o ["memberId" .= memId]
XGrpLeave -> JM.empty
XGrpDel -> JM.empty
XGrpInfo p -> o ["groupProfile" .= p]
XInfoProbe probe -> o ["probe" .= probe]
XInfoProbeCheck probeHash -> o ["probeHash" .= probeHash]
XInfoProbeOk probe -> o ["probe" .= probe]

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

@@ -64,6 +64,7 @@ module Simplex.Chat.Store
setGroupInvitationChatItemId,
getGroup,
getGroupInfo,
updateGroupProfile,
getGroupIdByName,
getGroupMemberIdByName,
getGroupInfoByName,
@@ -3077,6 +3078,38 @@ getGroupInfo db User {userId, userContactId} groupId =
|]
(groupId, userId, userContactId)
updateGroupProfile :: DB.Connection -> User -> GroupInfo -> GroupProfile -> ExceptT StoreError IO GroupInfo
updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, image}
| displayName == newName = liftIO $ do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs $> (g :: GroupInfo) {groupProfile = p'}
| otherwise =
ExceptT . withLocalDisplayName db userId newName $ \ldn -> do
currentTs <- getCurrentTime
updateGroupProfile_ currentTs
updateGroup_ ldn currentTs
pure $ (g :: GroupInfo) {localDisplayName = ldn, groupProfile = p'}
where
updateGroupProfile_ currentTs =
DB.execute
db
[sql|
UPDATE group_profiles
SET display_name = ?, full_name = ?, image = ?, updated_at = ?
WHERE group_profile_id IN (
SELECT group_profile_id
FROM groups
WHERE user_id = ? AND group_id = ?
)
|]
(newName, fullName, image, currentTs, userId, groupId)
updateGroup_ ldn currentTs = do
DB.execute
db
"UPDATE groups SET local_display_name = ?, updated_at = ? WHERE user_id = ? AND group_id = ?"
(ldn, currentTs, userId, groupId)
DB.execute db "DELETE FROM display_names WHERE local_display_name = ? AND user_id = ?" (localDisplayName, userId)
getAllChatItems :: DB.Connection -> User -> ChatPagination -> ExceptT StoreError IO [AChatItem]
getAllChatItems db user pagination = do
case pagination of

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

@@ -149,6 +149,7 @@ responseToView testView = \case
CRGroupEmpty g -> [ttyFullGroup g <> ": group is empty"]
CRGroupRemoved g -> [ttyFullGroup g <> ": you are no longer a member or group deleted"]
CRGroupDeleted g m -> [ttyGroup' g <> ": " <> ttyMember m <> " deleted the group", "use " <> highlight ("/d #" <> groupName' g) <> " to delete the local copy of the group"]
CRGroupUpdated g g' m -> viewGroupUpdated g g' m
CRMemberSubError g m e -> [ttyGroup' g <> " member " <> ttyMember m <> " error: " <> sShow e]
CRMemberSubSummary summary -> viewErrorsSummary (filter (isJust . memberError) summary) " group member errors"
CRGroupSubscribed g -> [ttyFullGroup g <> ": connected to server(s)"]
@@ -529,6 +530,18 @@ viewUserProfileUpdated Profile {displayName = n, fullName, image} Profile {displ
where
notified = " (your contacts are notified)"
viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> [StyledString]
viewGroupUpdated
GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, image}}
g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', image = image'}}
m
| n == n' && fullName == fullName' && image == image' = []
| n == n' && fullName == fullName' = ["group " <> ttyGroup n <> ": profile image " <> (if isNothing image' then "removed" else "updated") <> byMember]
| n == n' = ["group " <> ttyGroup n <> ": full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName' <> byMember]
| otherwise = ["group " <> ttyGroup n <> " is changed to " <> ttyFullGroup g' <> byMember]
where
byMember = maybe "" ((" by " <>) . ttyMember) m
viewContactUpdated :: Contact -> Contact -> [StyledString]
viewContactUpdated
Contact {localDisplayName = n, profile = Profile {fullName}}

29
tests/ChatTests.hs
View File

@@ -56,6 +56,7 @@ chatTests = do
it "group message quoted replies" testGroupMessageQuotedReply
it "group message update" testGroupMessageUpdate
it "group message delete" testGroupMessageDelete
it "update group profile" testUpdateGroupProfile
describe "async group connections" $ do
it "create and join group when clients go offline" testGroupAsync
describe "user profiles" $ do
@@ -1045,6 +1046,28 @@ testGroupMessageDelete =
bob #$> ("/_get chat #1 count=3", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((1, "hi alice"), Just (0, "hello!")), ((0, "this item is deleted (broadcast)"), Nothing)])
cath #$> ("/_get chat #1 count=2", chat', [((0, "this item is deleted (broadcast)"), Nothing), ((0, "hi alice"), Just (0, "hello!"))])
testUpdateGroupProfile :: IO ()
testUpdateGroupProfile =
testChat3 aliceProfile bobProfile cathProfile $
\alice bob cath -> do
createGroup3 "team" alice bob cath
threadDelay 1000000
alice #> "#team hello!"
concurrently_
(bob <# "#team alice> hello!")
(cath <# "#team alice> hello!")
bob ##> "/gp team my_team"
bob <## "you have insufficient permissions for this group command"
alice ##> "/gp team my_team"
alice <## "group #team is changed to #my_team"
concurrently_
(bob <## "group #team is changed to #my_team by alice")
(cath <## "group #team is changed to #my_team by alice")
bob #> "#my_team hi"
concurrently_
(alice <# "#my_team bob> hi")
(cath <# "#my_team bob> hi")
testGroupAsync :: IO ()
testGroupAsync = withTmpFiles $ do
print (0 :: Integer)
@@ -2607,8 +2630,10 @@ cc1 <#? cc2 = do
dropTime :: String -> String
dropTime msg = case splitAt 6 msg of
([m, m', ':', s, s', ' '], text) ->
if all isDigit [m, m', s, s'] then text else error "invalid time"
_ -> error "invalid time"
if all isDigit [m, m', s, s'] then text else err
_ -> err
where
err = error $ "invalid time: " <> msg
getInvitation :: TestCC -> IO String
getInvitation cc = do