fixing tests wip

src/Simplex/Chat.hs

@@ -1665,7 +1665,9 @@ processChatCommand' vr = \case
   APIMemberRole groupId memberId memRole -> withUser $ \user -> do
     Group gInfo@GroupInfo {membership} members <- withStore $ \db -> getGroup db vr user groupId
     if memberId == groupMemberId' membership
-      then changeMemberRole user gInfo members membership $ SGEUserRole memRole
+      then do
+        when (memRole < GRAdmin) $ deleteGroupLinkIfExists user gInfo
+        changeMemberRole user gInfo members membership $ SGEUserRole memRole
       else case find ((== memberId) . groupMemberId') members of
         Just m -> changeMemberRole user gInfo members m $ SGEMemberRole memberId (fromLocalProfile $ memberProfile m) memRole
         _ -> throwChatError CEGroupMemberNotFound
@@ -5490,21 +5492,28 @@ processAgentMessageConn vr user@User {userId} corrId agentConnId agentMessage =
     xGrpMemRole :: GroupInfo -> GroupMember -> MemberId -> GroupMemberRole -> RcvMessage -> UTCTime -> m ()
     xGrpMemRole gInfo@GroupInfo {membership} m@GroupMember {memberRole = senderRole} memId memRole msg brokerTs
       | membershipMemId == memId =
-          let gInfo' = gInfo {membership = membership {memberRole = memRole}}
-           in changeMemberRole gInfo' membership $ RGEUserRole memRole
+          checkRole membership $ do
+            when (memRole < GRAdmin) $ deleteGroupLinkIfExists user gInfo
+            let gInfo' = gInfo {membership = membership {memberRole = memRole}}
+            changeMemberRole gInfo' membership $ RGEUserRole memRole
       | otherwise =
           withStore' (\db -> runExceptT $ getGroupMemberByMemberId db vr user gInfo memId) >>= \case
-            Right member -> changeMemberRole gInfo member $ RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
+            Right member ->
+              checkRole member $ do
+                let gEvent = RGEMemberRole (groupMemberId' member) (fromLocalProfile $ memberProfile member) memRole
+                changeMemberRole gInfo member gEvent
             Left _ -> messageError "x.grp.mem.role with unknown member ID"
       where
         GroupMember {memberId = membershipMemId} = membership
-        changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent
-          | senderRole < GRAdmin || senderRole < fromRole = messageError "x.grp.mem.role with insufficient member permissions"
-          | otherwise = do
-              withStore' $ \db -> updateGroupMemberRole db user member memRole
-              ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
-              groupMsgToView gInfo ci
-              toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
+        checkRole GroupMember {memberRole = fromRole} a
+          | senderRole < GRAdmin || senderRole < fromRole =
+              messageError "x.grp.mem.role with insufficient member permissions"
+          | otherwise = a
+        changeMemberRole gInfo' member@GroupMember {memberRole = fromRole} gEvent = do
+          withStore' $ \db -> updateGroupMemberRole db user member memRole
+          ci <- saveRcvChatItem user (CDGroupRcv gInfo m) msg brokerTs (CIRcvGroupEvent gEvent)
+          groupMsgToView gInfo ci
+          toView CRMemberRole {user, groupInfo = gInfo', byMember = m, member = member {memberRole = memRole}, fromRole, toRole = memRole}
 
     checkHostRole :: GroupMember -> GroupMemberRole -> m ()
     checkHostRole GroupMember {memberRole, localDisplayName} memRole =

tests/Bots/DirectoryTests.hs

@@ -38,7 +38,7 @@ directoryServiceTests = do
     it "should de-list if service is removed from the group" testDelistedServiceRemoved
     it "should de-list/re-list when service/owner roles change" testDelistedRoleChanges
     it "should NOT de-list if another member role changes" testNotDelistedMemberRoleChanged
-    it "should NOT send to approval if roles are incorrect" testNotSentApprovalBadRoles
+    fit "should NOT send to approval if roles are incorrect" testNotSentApprovalBadRoles
     it "should NOT allow approving if roles are incorrect" testNotApprovedBadRoles
   describe "should require re-approval if profile is changed by" $ do
     it "the registration owner" testRegOwnerChangedProfile
@@ -55,7 +55,7 @@ directoryServiceTests = do
   describe "list groups" $ do
     it "should list user's groups" testListUserGroups
   describe "store log" $ do
-    it "should restore directory service state" testRestoreDirectory
+    fit "should restore directory service state" testRestoreDirectory
 
 directoryProfile :: Profile
 directoryProfile = Profile {displayName = "SimpleX-Directory", fullName = "", image = Nothing, contactLink = Nothing, preferences = Nothing}

tests/ChatClient.hs

@@ -346,8 +346,8 @@ getTermLine cc =
   5000000 `timeout` atomically (readTQueue $ termQ cc) >>= \case
     Just s -> do
       -- remove condition to always echo virtual terminal
-      -- when True $ do
-      when (printOutput cc) $ do
+      when True $ do
+      -- when (printOutput cc) $ do
         name <- userName cc
         putStrLn $ name <> ": " <> s
       pure s

tests/ChatTests/Groups.hs

@@ -78,6 +78,7 @@ chatGroupTests = do
     it "invitee incognito" testGroupLinkNoContactInviteeIncognito
     it "host profile received" testGroupLinkNoContactHostProfileReceived
     it "existing contact merged" testGroupLinkNoContactExistingContactMerged
+    it "group link is deleted if user role lowers below admin" testGroupLinkUserRoleLowers
   describe "group links without contact connection plan" $ do
     it "group link without contact - known group" testPlanGroupLinkNoContactKnown
     it "group link without contact - connecting" testPlanGroupLinkNoContactConnecting
@@ -3114,6 +3115,60 @@ testGroupLinkNoContactExistingContactMerged =
       bob #> "#team hi there"
       alice <# "#team bob> hi there"
 
+testGroupLinkUserRoleLowers :: HasCallStack => FilePath -> IO ()
+testGroupLinkUserRoleLowers =
+  testChat3 aliceProfile bobProfile cathProfile $
+    \alice bob cath -> do
+      alice ##> "/g team"
+      alice <## "group #team is created"
+      alice <## "to add members use /a team <name> or /create link #team"
+
+      alice ##> "/set history #team off"
+      alice <## "updated group preferences:"
+      alice <## "Recent history: off"
+
+      alice ##> "/create link #team"
+      gLink <- getGroupLink alice "team" GRMember True
+
+      -- lowering role from owner to admin - link works
+      alice ##> "/mr #team alice admin"
+      alice <## "#team: you changed your role from owner to admin"
+
+      bob ##> ("/c " <> gLink)
+      bob <## "connection request sent!"
+      alice <## "bob (Bob): accepting request to join group #team..."
+      concurrentlyN_
+        [ alice <## "#team: bob joined the group",
+          do
+            bob <## "#team: joining the group..."
+            bob <## "#team: you joined the group"
+        ]
+
+      alice #> "#team hello"
+      bob <# "#team alice> hello"
+      bob #> "#team hi there"
+      alice <# "#team bob> hi there"
+
+      alice ##> "/mr #team bob admin"
+      alice <## "#team: you changed the role of bob from member to admin"
+      bob <## "#team: alice changed your role from member to admin"
+
+      -- lowering role below admin - link is deleted
+      bob ##> "/mr #team alice member"
+      bob <## "#team: you changed the role of alice from admin to member"
+      alice <## "#team: bob changed your role from admin to member"
+
+      cath ##> ("/c " <> gLink)
+      cath <## "error: connection authorization failed - this could happen if connection was deleted, secured with different credentials, or due to a bug - please re-create the connection"
+      cath ##> "/gs"
+      cath <## "you have no groups!"
+      cath <## "to create: /g <name>"
+
+      alice #> "#team hello"
+      bob <# "#team alice> hello"
+      bob #> "#team hi there"
+      alice <# "#team bob> hi there"
+
 testPlanGroupLinkNoContactKnown :: HasCallStack => FilePath -> IO ()
 testPlanGroupLinkNoContactKnown =
   testChat2 aliceProfile bobProfile $