From 33e75381720c60d4dc57f601fbb865b9567d5b3d Mon Sep 17 00:00:00 2001 From: Evgeny Poberezkin <2769109+epoberezkin@users.noreply.github.com> Date: Sat, 10 Dec 2022 08:27:32 +0000 Subject: [PATCH] core: group description (#1538) * core: group description * support multi-line welcome message * fix --- simplex-chat.cabal | 1 + src/Simplex/Chat.hs | 34 +++++--- src/Simplex/Chat/Controller.hs | 5 +- src/Simplex/Chat/Help.hs | 2 + .../Migrations/M20221211_group_description.hs | 12 +++ src/Simplex/Chat/Migrations/chat_schema.sql | 3 +- src/Simplex/Chat/Store.hs | 41 +++++----- src/Simplex/Chat/Types.hs | 1 + src/Simplex/Chat/View.hs | 33 +++++--- tests/ChatClient.hs | 2 +- tests/ChatTests.hs | 79 +++++++++++++++++-- tests/ProtocolTests.hs | 2 +- 12 files changed, 166 insertions(+), 49 deletions(-) create mode 100644 src/Simplex/Chat/Migrations/M20221211_group_description.hs diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c221239cd..6f6df34e8 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -67,6 +67,7 @@ library Simplex.Chat.Migrations.M20221130_delete_item_deleted Simplex.Chat.Migrations.M20221209_verified_connection Simplex.Chat.Migrations.M20221210_idxs + Simplex.Chat.Migrations.M20221211_group_description Simplex.Chat.Mobile Simplex.Chat.Options Simplex.Chat.ProfileGenerator diff --git a/src/Simplex/Chat.hs b/src/Simplex/Chat.hs index 28149a804..231a5e25d 100644 --- a/src/Simplex/Chat.hs +++ b/src/Simplex/Chat.hs @@ -1020,9 +1020,12 @@ processChatCommand = \case APIUpdateGroupProfile groupId p' -> withUser $ \user -> do g <- withStore $ \db -> getGroup db user groupId runUpdateGroupProfile user g p' - UpdateGroupProfile gName profile -> withUser $ \user -> do - groupId <- withStore $ \db -> getGroupIdByName db user gName - processChatCommand $ APIUpdateGroupProfile groupId profile + UpdateGroupNames gName GroupProfile {displayName, fullName} -> + updateGroupProfileByName gName $ \p -> p {displayName, fullName} + ShowGroupProfile gName -> withUser $ \user -> + CRGroupProfile <$> withStore (\db -> getGroupInfoByName db user gName) + UpdateGroupDescription gName description -> + updateGroupProfileByName gName $ \p -> p {description} APICreateGroupLink groupId -> withUser $ \user -> withChatLock "createGroupLink" $ do gInfo@GroupInfo {membership = membership@GroupMember {memberRole = userRole}} <- withStore $ \db -> getGroupInfo db user groupId when (userRole < GRAdmin) $ throwChatError CEGroupUserRole @@ -1117,10 +1120,9 @@ processChatCommand = \case ct@Contact {userPreferences} <- withStore $ \db -> getContactByName db user cName let prefs' = setPreference f allowed_ $ Just userPreferences updateContactPrefs user ct prefs' - SetGroupFeature f gName enabled -> withUser $ \user -> do - g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> getGroup db user =<< getGroupIdByName db user gName - let p' = p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} - runUpdateGroupProfile user g p' + SetGroupFeature f gName enabled -> + updateGroupProfileByName gName $ \p -> + p {groupPreferences = Just . setGroupPreference f enabled $ groupPreferences p} QuitChat -> liftIO exitSuccess ShowVersion -> pure $ CRVersionInfo versionNumber DebugLocks -> do @@ -1257,6 +1259,11 @@ processChatCommand = \case toView . CRNewChatItem $ AChatItem SCTGroup SMDSnd (GroupChat g') ci createGroupFeatureChangedItems user cd CISndGroupFeature p p' pure $ CRGroupUpdated g g' Nothing + updateGroupProfileByName :: GroupName -> (GroupProfile -> GroupProfile) -> m ChatResponse + updateGroupProfileByName gName update = withUser $ \user -> do + g@(Group GroupInfo {groupProfile = p} _) <- withStore $ \db -> + getGroupIdByName db user gName >>= getGroup db user + runUpdateGroupProfile user g $ update p isReady :: Contact -> Bool isReady ct = let s = connStatus $ activeConn (ct :: Contact) @@ -1957,7 +1964,9 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = GCHostMember -> do toView $ CRUserJoinedGroup gInfo {membership = membership {memberStatus = GSMemConnected}} m {memberStatus = GSMemConnected} createGroupFeatureItems gInfo m + let GroupInfo {groupProfile = GroupProfile {description}} = gInfo memberConnectedChatItem gInfo m + forM_ description $ groupDescriptionChatItem gInfo m setActive $ ActiveG gName showToast ("#" <> gName) "you are connected to group" GCInviteeMember -> do @@ -2233,6 +2242,10 @@ processAgentMessage (Just user@User {userId}) corrId agentConnId agentMessage = -- ts should be broker ts but we don't have it for CON createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvGroupEvent RGEMemberConnected) Nothing + groupDescriptionChatItem :: GroupInfo -> GroupMember -> Text -> m () + groupDescriptionChatItem gInfo m descr = + createInternalChatItem user (CDGroupRcv gInfo m) (CIRcvMsgContent $ MCText descr) Nothing + notifyMemberConnected :: GroupInfo -> GroupMember -> m () notifyMemberConnected gInfo m@GroupMember {localDisplayName = c} = do memberConnectedChatItem gInfo m @@ -3454,8 +3467,9 @@ chatCommandP = ("/members " <|> "/ms ") *> char_ '#' *> (ListMembers <$> displayName), ("/groups" <|> "/gs") $> ListGroups, "/_group_profile #" *> (APIUpdateGroupProfile <$> A.decimal <* A.space <*> jsonP), - -- TODO group profile update via terminal should not reset image and preferences to Nothing (now it does) - ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupProfile <$> displayName <* A.space <*> groupProfile), + ("/group_profile " <|> "/gp ") *> char_ '#' *> (UpdateGroupNames <$> displayName <* A.space <*> groupProfile), + ("/group_profile " <|> "/gp ") *> char_ '#' *> (ShowGroupProfile <$> displayName), + "/group_descr " *> char_ '#' *> (UpdateGroupDescription <$> displayName <*> optional (A.space *> (jsonP <|> textP))), "/_create link #" *> (APICreateGroupLink <$> A.decimal), "/_delete link #" *> (APIDeleteGroupLink <$> A.decimal), "/_get link #" *> (APIGetGroupLink <$> A.decimal), @@ -3537,7 +3551,7 @@ chatCommandP = gName <- displayName fullName <- fullNameP gName let groupPreferences = Just (emptyGroupPrefs :: GroupPreferences) {directMessages = Just GroupPreference {enable = FEOn}} - pure GroupProfile {displayName = gName, fullName, image = Nothing, groupPreferences} + pure GroupProfile {displayName = gName, fullName, description = Nothing, image = Nothing, groupPreferences} fullNameP name = do n <- (A.space *> A.takeByteString) <|> pure "" pure $ if B.null n then name else safeDecodeUtf8 n diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index 123554240..09d1fffd7 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -242,7 +242,9 @@ data ChatCommand | ClearGroup GroupName | ListMembers GroupName | ListGroups - | UpdateGroupProfile GroupName GroupProfile + | UpdateGroupNames GroupName GroupProfile + | ShowGroupProfile GroupName + | UpdateGroupDescription GroupName (Maybe Text) | CreateGroupLink GroupName | DeleteGroupLink GroupName | ShowGroupLink GroupName @@ -368,6 +370,7 @@ data ChatResponse | CRGroupRemoved {groupInfo :: GroupInfo} | CRGroupDeleted {groupInfo :: GroupInfo, member :: GroupMember} | CRGroupUpdated {fromGroup :: GroupInfo, toGroup :: GroupInfo, member_ :: Maybe GroupMember} + | CRGroupProfile {groupInfo :: GroupInfo} | CRGroupLinkCreated {groupInfo :: GroupInfo, connReqContact :: ConnReqContact} | CRGroupLink {groupInfo :: GroupInfo, connReqContact :: ConnReqContact} | CRGroupLinkDeleted {groupInfo :: GroupInfo} diff --git a/src/Simplex/Chat/Help.hs b/src/Simplex/Chat/Help.hs index 497184b54..060532812 100644 --- a/src/Simplex/Chat/Help.hs +++ b/src/Simplex/Chat/Help.hs @@ -123,7 +123,9 @@ groupsHelpInfo = indent <> highlight "/leave " <> " - leave group", indent <> highlight "/delete " <> " - delete group", indent <> highlight "/members " <> " - list group members", + indent <> highlight "/gp " <> " - view group profile", indent <> highlight "/gp [] " <> " - update group profile", + indent <> highlight "/group_descr [] " <> " - update/remove group description", indent <> highlight "/groups " <> " - list groups", indent <> highlight "# " <> " - send message to group", indent <> highlight "/create link # " <> " - create public group link", diff --git a/src/Simplex/Chat/Migrations/M20221211_group_description.hs b/src/Simplex/Chat/Migrations/M20221211_group_description.hs new file mode 100644 index 000000000..ba406862c --- /dev/null +++ b/src/Simplex/Chat/Migrations/M20221211_group_description.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Simplex.Chat.Migrations.M20221211_group_description where + +import Database.SQLite.Simple (Query) +import Database.SQLite.Simple.QQ (sql) + +m20221211_group_description :: Query +m20221211_group_description = + [sql| +ALTER TABLE group_profiles ADD COLUMN description TEXT NULL; +|] diff --git a/src/Simplex/Chat/Migrations/chat_schema.sql b/src/Simplex/Chat/Migrations/chat_schema.sql index 9a9ca9d12..3de5440c6 100644 --- a/src/Simplex/Chat/Migrations/chat_schema.sql +++ b/src/Simplex/Chat/Migrations/chat_schema.sql @@ -116,7 +116,8 @@ CREATE TABLE group_profiles( updated_at TEXT CHECK(updated_at NOT NULL), image TEXT, user_id INTEGER DEFAULT NULL REFERENCES users ON DELETE CASCADE, - preferences TEXT + preferences TEXT, + description TEXT NULL ); CREATE TABLE groups( group_id INTEGER PRIMARY KEY, -- local group ID diff --git a/src/Simplex/Chat/Store.hs b/src/Simplex/Chat/Store.hs index e1ddfc5aa..681051bb6 100644 --- a/src/Simplex/Chat/Store.hs +++ b/src/Simplex/Chat/Store.hs @@ -307,6 +307,7 @@ import Simplex.Chat.Migrations.M20221129_delete_group_feature_items import Simplex.Chat.Migrations.M20221130_delete_item_deleted import Simplex.Chat.Migrations.M20221209_verified_connection import Simplex.Chat.Migrations.M20221210_idxs +import Simplex.Chat.Migrations.M20221211_group_description import Simplex.Chat.Protocol import Simplex.Chat.Types import Simplex.Messaging.Agent.Protocol (ACorrId, AgentMsgId, ConnId, InvitationId, MsgMeta (..)) @@ -359,7 +360,8 @@ schemaMigrations = ("20221129_delete_group_feature_items", m20221129_delete_group_feature_items), ("20221130_delete_item_deleted", m20221130_delete_item_deleted), ("20221209_verified_connection", m20221209_verified_connection), - ("20221210_idxs", m20221210_idxs) + ("20221210_idxs", m20221210_idxs), + ("20221211_group_description", m20221211_group_description) ] -- | The list of migrations in ascending order by date @@ -1509,7 +1511,7 @@ getConnectionEntity db user@User {userId, userContactId} agentConnId = do [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -1610,7 +1612,7 @@ getGroupAndMember db User {userId, userContactId} groupMemberId = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -1650,15 +1652,15 @@ updateConnectionStatus db Connection {connId} connStatus = do -- | creates completely new group with a single member - the current user createNewGroup :: DB.Connection -> TVar ChaChaDRG -> User -> GroupProfile -> ExceptT StoreError IO GroupInfo createNewGroup db gVar user@User {userId} groupProfile = ExceptT $ do - let GroupProfile {displayName, fullName, image, groupPreferences} = groupProfile + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile fullGroupPreferences = mergeGroupPreferences groupPreferences currentTs <- getCurrentTime withLocalDisplayName db userId displayName $ \ldn -> runExceptT $ do groupId <- liftIO $ do DB.execute db - "INSERT INTO group_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (displayName, fullName, image, userId, groupPreferences, currentTs, currentTs) + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) profileId <- insertedRowId db DB.execute db @@ -1694,7 +1696,7 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo DB.query db "SELECT group_id FROM groups WHERE inv_queue_info = ? AND user_id = ? LIMIT 1" (connRequest, userId) createGroupInvitation_ :: ExceptT StoreError IO (GroupInfo, GroupMemberId) createGroupInvitation_ = do - let GroupProfile {displayName, fullName, image, groupPreferences} = groupProfile + let GroupProfile {displayName, fullName, description, image, groupPreferences} = groupProfile fullGroupPreferences = mergeGroupPreferences groupPreferences ExceptT $ withLocalDisplayName db userId displayName $ \localDisplayName -> runExceptT $ do @@ -1702,8 +1704,8 @@ createGroupInvitation db user@User {userId} contact@Contact {contactId, activeCo groupId <- liftIO $ do DB.execute db - "INSERT INTO group_profiles (display_name, full_name, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?)" - (displayName, fullName, image, userId, groupPreferences, currentTs, currentTs) + "INSERT INTO group_profiles (display_name, full_name, description, image, user_id, preferences, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?)" + (displayName, fullName, description, image, userId, groupPreferences, currentTs, currentTs) profileId <- insertedRowId db DB.execute db @@ -1849,7 +1851,7 @@ getUserGroupDetails db User {userId, userContactId} = <$> DB.query db [sql| - SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + SELECT g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, mu.group_member_id, g.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, pu.display_name, pu.full_name, pu.image, pu.local_alias, pu.preferences FROM groups g @@ -1883,14 +1885,15 @@ getGroupInfoByName db user gName = do gId <- getGroupIdByName db user gName getGroupInfo db user gId -type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime) :. GroupMemberRow +type GroupInfoRow = (Int64, GroupName, GroupName, Text, Maybe Text, Maybe ImageData, Maybe ProfileId, Maybe Bool, Maybe GroupPreferences, UTCTime, UTCTime) :. GroupMemberRow toGroupInfo :: Int64 -> GroupInfoRow -> GroupInfo -toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt) :. userMemberRow) = +toGroupInfo userContactId ((groupId, localDisplayName, displayName, fullName, description, image, hostConnCustomUserProfileId, enableNtfs_, groupPreferences, createdAt, updatedAt) :. userMemberRow) = let membership = toGroupMember userContactId userMemberRow chatSettings = ChatSettings {enableNtfs = fromMaybe True enableNtfs_} fullGroupPreferences = mergeGroupPreferences groupPreferences - in GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName, fullName, image, groupPreferences}, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt} + groupProfile = GroupProfile {displayName, fullName, description, image, groupPreferences} + in GroupInfo {groupId, localDisplayName, groupProfile, fullGroupPreferences, membership, hostConnCustomUserProfileId, chatSettings, createdAt, updatedAt} getGroupMember :: DB.Connection -> User -> GroupId -> GroupMemberId -> ExceptT StoreError IO GroupMember getGroupMember db user@User {userId} groupId groupMemberId = @@ -2366,7 +2369,7 @@ getViaGroupMember db User {userId, userContactId} Contact {contactId} = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, -- GroupInfo {membership} mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -3348,7 +3351,7 @@ getGroupChatPreviews_ db User {userId, userContactId} = do [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -3714,7 +3717,7 @@ getGroupInfo db User {userId, userContactId} groupId = [sql| SELECT -- GroupInfo - g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, + g.group_id, g.local_display_name, gp.display_name, gp.full_name, gp.description, gp.image, g.host_conn_custom_user_profile_id, g.enable_ntfs, gp.preferences, g.created_at, g.updated_at, -- GroupMember - membership mu.group_member_id, mu.group_id, mu.member_id, mu.member_role, mu.member_category, mu.member_status, mu.invited_by, mu.local_display_name, mu.contact_id, mu.contact_profile_id, pu.contact_profile_id, @@ -3728,7 +3731,7 @@ 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, groupPreferences} +updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, groupProfile = GroupProfile {displayName}} p'@GroupProfile {displayName = newName, fullName, description, image, groupPreferences} | displayName == newName = liftIO $ do currentTs <- getCurrentTime updateGroupProfile_ currentTs $> (g :: GroupInfo) {groupProfile = p', fullGroupPreferences} @@ -3745,14 +3748,14 @@ updateGroupProfile db User {userId} g@GroupInfo {groupId, localDisplayName, grou db [sql| UPDATE group_profiles - SET display_name = ?, full_name = ?, image = ?, preferences = ?, updated_at = ? + SET display_name = ?, full_name = ?, description = ?, image = ?, preferences = ?, updated_at = ? WHERE group_profile_id IN ( SELECT group_profile_id FROM groups WHERE user_id = ? AND group_id = ? ) |] - (newName, fullName, image, groupPreferences, currentTs, userId, groupId) + (newName, fullName, description, image, groupPreferences, currentTs, userId, groupId) updateGroup_ ldn currentTs = do DB.execute db diff --git a/src/Simplex/Chat/Types.hs b/src/Simplex/Chat/Types.hs index f03b3d5c6..3f7599d32 100644 --- a/src/Simplex/Chat/Types.hs +++ b/src/Simplex/Chat/Types.hs @@ -724,6 +724,7 @@ fromLocalProfile LocalProfile {displayName, fullName, image, preferences} = data GroupProfile = GroupProfile { displayName :: GroupName, fullName :: Text, + description :: Maybe Text, image :: Maybe ImageData, groupPreferences :: Maybe GroupPreferences } diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index 4ba46591f..ce834335c 100644 --- a/src/Simplex/Chat/View.hs +++ b/src/Simplex/Chat/View.hs @@ -184,6 +184,7 @@ responseToView user_ testView ts = \case 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 + CRGroupProfile g -> viewGroupProfile g CRGroupLinkCreated g cReq -> groupLink_ "Group link is created!" g cReq CRGroupLink g cReq -> groupLink_ "Group link:" g cReq CRGroupLinkDeleted g -> viewGroupLinkDeleted g @@ -809,8 +810,8 @@ viewCountactUserPref = \case viewGroupUpdated :: GroupInfo -> GroupInfo -> Maybe GroupMember -> [StyledString] viewGroupUpdated - GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, image, groupPreferences = gps}} - g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', image = image', groupPreferences = gps'}} + GroupInfo {localDisplayName = n, groupProfile = GroupProfile {fullName, description, image, groupPreferences = gps}} + g'@GroupInfo {localDisplayName = n', groupProfile = GroupProfile {fullName = fullName', description = description', image = image', groupPreferences = gps'}} m = do let update = groupProfileUpdated <> groupPrefsUpdated if null update @@ -818,21 +819,35 @@ viewGroupUpdated else memberUpdated <> update where memberUpdated = maybe [] (\m' -> [ttyMember m' <> " updated group " <> ttyGroup n <> ":"]) m - groupProfileUpdated - | n == n' && fullName == fullName' && image == image' = [] - | n == n' && fullName == fullName' = ["profile image " <> (if isNothing image' then "removed" else "updated")] - | n == n' = ["full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to " <> plain fullName'] - | otherwise = ["changed to " <> ttyFullGroup g'] + groupProfileUpdated = + ["changed to " <> ttyFullGroup g' | n /= n'] + <> ["full name " <> if T.null fullName' || fullName' == n' then "removed" else "changed to: " <> plain fullName' | n == n' && fullName /= fullName'] + <> ["profile image " <> maybe "removed" (const "updated") image' | image /= image'] + <> (if description == description' then [] else maybe ["description removed"] ((bold' "description changed to:" :) . map plain . T.lines) description') groupPrefsUpdated | null prefs = [] - | otherwise = "updated group preferences:" : prefs + | otherwise = bold' "updated group preferences:" : prefs where prefs = mapMaybe viewPref allGroupFeatures viewPref pt | pref gps == pref gps' = Nothing | otherwise = Just $ plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps') where - pref pss = getGroupPreference pt $ mergeGroupPreferences pss + pref = getGroupPreference pt . mergeGroupPreferences + +viewGroupProfile :: GroupInfo -> [StyledString] +viewGroupProfile g@GroupInfo {groupProfile = GroupProfile {description, image, groupPreferences = gps}} = + [ttyFullGroup g] + <> maybe [] (const ["has profile image"]) image + <> maybe [] ((bold' "description:" :) . map plain . T.lines) description + <> (bold' "group preferences:" : map viewPref allGroupFeatures) + where + viewPref pt = plain (groupFeatureToText pt) <> " enabled: " <> plain (groupPrefToText $ pref gps) + where + pref = getGroupPreference pt . mergeGroupPreferences + +bold' :: String -> StyledString +bold' = styled Bold viewContactAliasUpdated :: Contact -> [StyledString] viewContactAliasUpdated Contact {localDisplayName = n, profile = LocalProfile {localAlias}} diff --git a/tests/ChatClient.hs b/tests/ChatClient.hs index 4b1f6daa5..c85f350bb 100644 --- a/tests/ChatClient.hs +++ b/tests/ChatClient.hs @@ -215,7 +215,7 @@ getTermLine :: TestCC -> IO String getTermLine cc = 5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case Just s -> do - -- uncomment code below to echo virtual terminal + -- uncomment 2 lines below to echo virtual terminal -- name <- userName cc -- putStrLn $ name <> ": " <> s pure s diff --git a/tests/ChatTests.hs b/tests/ChatTests.hs index 63348b042..f5b2c2908 100644 --- a/tests/ChatTests.hs +++ b/tests/ChatTests.hs @@ -76,6 +76,7 @@ chatTests = do it "update group profile" testUpdateGroupProfile it "update member role" testUpdateMemberRole it "unused contacts are deleted after all their groups are deleted" testGroupDeleteUnusedContacts + it "group description is shown as the first message to new members" testGroupDescription describe "async group connections" $ do xit "create and join group when clients go offline" testGroupAsync describe "user profiles" $ do @@ -1500,6 +1501,70 @@ testGroupDeleteUnusedContacts = cath ##> ("/d #" <> group) cath <## ("#" <> group <> ": you deleted the group") +testGroupDescription :: IO () +testGroupDescription = testChat4 aliceProfile bobProfile cathProfile danProfile $ \alice bob cath dan -> do + connectUsers alice bob + alice ##> "/g team" + alice <## "group #team is created" + alice <## "to add members use /a team or /create link #team" + addMember "team" alice bob GRAdmin + bob ##> "/j team" + concurrentlyN_ + [ alice <## "#team: bob joined the group", + bob <## "#team: you joined the group" + ] + alice ##> "/group_profile team" + alice <## "#team" + groupInfo alice + alice ##> "/group_descr team Welcome to the team!" + alice <## "description changed to:" + alice <## "Welcome to the team!" + bob <## "alice updated group #team:" + bob <## "description changed to:" + bob <## "Welcome to the team!" + alice ##> "/group_profile team" + alice <## "#team" + alice <## "description:" + alice <## "Welcome to the team!" + groupInfo alice + connectUsers alice cath + addMember "team" alice cath GRMember + cath ##> "/j team" + concurrentlyN_ + [ alice <## "#team: cath joined the group", + do + cath <## "#team: you joined the group" + cath <# "#team alice> Welcome to the team!" + cath <## "#team: member bob (Bob) is connected", + do + bob <## "#team: alice added cath (Catherine) to the group (connecting...)" + bob <## "#team: new member cath is connected" + ] + connectUsers bob dan + addMember "team" bob dan GRMember + dan ##> "/j team" + concurrentlyN_ + [ bob <## "#team: dan joined the group", + do + dan <## "#team: you joined the group" + dan <# "#team bob> Welcome to the team!" + dan + <### [ "#team: member alice (Alice) is connected", + "#team: member cath (Catherine) is connected" + ], + bobAddedDan alice, + bobAddedDan cath + ] + where + groupInfo alice = do + alice <## "group preferences:" + alice <## "Direct messages enabled: on" + alice <## "Full deletion enabled: off" + alice <## "Voice messages enabled: on" + bobAddedDan cc = do + cc <## "#team: bob added dan (Daniel) to the group (connecting...)" + cc <## "#team: new member dan is connected" + testGroupAsync :: IO () testGroupAsync = withTmpFiles $ do print (0 :: Integer) @@ -3449,19 +3514,19 @@ testProhibitDirectMessages = addMember "team" cath dan GRMember dan ##> "/j #team" concurrentlyN_ - [ cath <## ("#team: dan joined the group"), + [ cath <## "#team: dan joined the group", do - dan <## ("#team: you joined the group") + dan <## "#team: you joined the group" dan <### [ "#team: member alice (Alice) is connected", "#team: member bob (Bob) is connected" ], do - alice <## ("#team: cath added dan (Daniel) to the group (connecting...)") - alice <## ("#team: new member dan is connected"), + alice <## "#team: cath added dan (Daniel) to the group (connecting...)" + alice <## "#team: new member dan is connected", do - bob <## ("#team: cath added dan (Daniel) to the group (connecting...)") - bob <## ("#team: new member dan is connected") + bob <## "#team: cath added dan (Daniel) to the group (connecting...)" + bob <## "#team: new member dan is connected" ] alice ##> "@dan hi" alice <## "direct messages to indirect contact dan are prohibited" @@ -3508,7 +3573,7 @@ testTestSMPServerConnection = alice ##> "/smp test smp://LcJUMfVhwD8yxjAiSaDzzGF3-kLG4Uh0Fl_ZIjrRwjI=:server_password@localhost:5001" alice <## "SMP server test passed" alice ##> "/smp test smp://LcJU@localhost:5001" - alice <## ("SMP server test failed at Connect, error: BROKER smp://LcJU@localhost:5001 NETWORK") + alice <## "SMP server test failed at Connect, error: BROKER smp://LcJU@localhost:5001 NETWORK" alice <## "Possibly, certificate fingerprint in server address is incorrect" testAsyncInitiatingOffline :: IO () diff --git a/tests/ProtocolTests.hs b/tests/ProtocolTests.hs index 753fe9125..61365b213 100644 --- a/tests/ProtocolTests.hs +++ b/tests/ProtocolTests.hs @@ -89,7 +89,7 @@ testProfile :: Profile testProfile = Profile {displayName = "alice", fullName = "Alice", image = Just (ImageData "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAAgAAAAIAQMAAAD+wSzIAAAABlBMVEX///+/v7+jQ3Y5AAAADklEQVQI12P4AIX8EAgALgAD/aNpbtEAAAAASUVORK5CYII="), preferences = testChatPreferences} testGroupProfile :: GroupProfile -testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", image = Nothing, groupPreferences = testGroupPreferences} +testGroupProfile = GroupProfile {displayName = "team", fullName = "Team", description = Nothing, image = Nothing, groupPreferences = testGroupPreferences} decodeChatMessageTest :: Spec decodeChatMessageTest = describe "Chat message encoding/decoding" $ do