directory: fix search cursor (#7361)

apps/simplex-directory-service/src/Directory/Search.hs

@@ -1,5 +1,6 @@
 module Directory.Search where
 
+import Data.Int (Int64)
 import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Types
@@ -7,7 +8,15 @@ import Simplex.Chat.Types
 data SearchRequest = SearchRequest
   { searchType :: SearchType,
     searchTime :: UTCTime,
-    lastGroup :: GroupId -- cursor for search
+    searchCursor :: SearchCursor
+  }
+
+-- Position of the last sent row in the sort order of its search type. Each mode
+-- reads the value it sorts by; the group ID breaks ties, as neither sort key is unique.
+data SearchCursor = SearchCursor
+  { lastMembers :: Int64,
+    lastCreatedAt :: UTCTime,
+    lastGroupId :: GroupId
   }
 
 data SearchType = STAll | STRecent | STSearch Text

apps/simplex-directory-service/src/Directory/Service.hs

@@ -1126,14 +1126,14 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
           isGroupLink _ = False
       DCSearchNext ->
         atomically (TM.lookup (contactId' ct) searchRequests) >>= \case
-          Just SearchRequest {searchType, searchTime, lastGroup} -> do
+          Just SearchRequest {searchType, searchTime, searchCursor} -> do
             currentTime <- getCurrentTime
             if diffUTCTime currentTime searchTime > 300 -- 5 minutes
               then do
                 atomically $ TM.delete (contactId' ct) searchRequests
                 showAllGroups
               else
-                sendFoundListedGroups searchType (Just lastGroup) "No more groups" $ \gs _ ->
+                sendFoundListedGroups searchType (Just searchCursor) "No more groups" $ \gs _ ->
                   "Sending " <> tshow (length gs) <> " more group(s)."
           Nothing -> showAllGroups
         where
@@ -1280,8 +1280,8 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
               | maybe True (displayName ==) gName_ -> action g gr
               | otherwise -> sendReply $ "Group ID " <> tshow ugrId <> " has the display name " <> displayName
         sendReply = mkSendReply ct ciId
-        sendFoundListedGroups searchType lastGroup_ notFound replyStr =
-          searchListedGroups cc user searchType lastGroup_ searchResults >>= \case
+        sendFoundListedGroups searchType cursor_ notFound replyStr =
+          searchListedGroups cc user searchType cursor_ searchResults >>= \case
             Right ([], _) -> do
               atomically $ TM.delete (contactId' ct) searchRequests
               sendReply notFound
@@ -1294,9 +1294,10 @@ directoryServiceEvent opts@DirectoryOpts {adminUsers, superUsers, serviceName, o
           let more = if n > length gs then ", sending " <> sortName <> " " <> tshow (length gs) else ""
            in tshow n <> " group(s) listed" <> more <> "."
         updateSearchRequest :: SearchType -> (GroupInfo, GroupReg) -> IO ()
-        updateSearchRequest searchType (GroupInfo {groupId}, _) = do
+        updateSearchRequest searchType (GroupInfo {groupId, groupSummary = GroupSummary {currentMembers}}, GroupReg {createdAt}) = do
           searchTime <- getCurrentTime
-          let search = SearchRequest {searchType, searchTime, lastGroup = groupId}
+          let searchCursor = SearchCursor {lastMembers = currentMembers, lastCreatedAt = createdAt, lastGroupId = groupId}
+              search = SearchRequest {searchType, searchTime, searchCursor}
           atomically $ TM.insert (contactId' ct) search searchRequests
         sendFoundGroups reply gs moreGroups =
           void . forkIO $ sendComposedMessages_ cc (SRDirect $ contactId' ct) msgs

apps/simplex-directory-service/src/Directory/Store.hs

@@ -340,43 +340,41 @@ getAllListedGroups_ db cxt user@User {userId, userContactId} = do
   where
     withGroupLink (g, gr) = (g,gr,) . eitherToMaybe <$> runExceptT (getGroupLink db user g)
 
-searchListedGroups :: ChatController -> User -> SearchType -> Maybe GroupId -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
-searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pageSize =
+searchListedGroups :: ChatController -> User -> SearchType -> Maybe SearchCursor -> Int -> IO (Either String ([(GroupInfo, GroupReg)], Int))
+searchListedGroups cc user@User {userId, userContactId} searchType cursor_ pageSize =
   withDB' "searchListedGroups" cc $ \db -> do
     currentTs <- getCurrentTime
     case searchType of
-      STAll -> case lastGroup_ of
+      STAll -> case cursor_ of
         Nothing -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
           n <- count $ DB.query db countQuery' (Only GRSActive)
           pure (gs, n)
-        Just gId -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize)
-          n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId)
+        Just SearchCursor {lastMembers, lastGroupId} -> do
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersCond <> membersOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, lastMembers, lastMembers, lastGroupId, pageSize)
+          n <- count $ DB.query db (countQuery' <> membersCond) (GRSActive, lastMembers, lastMembers, lastGroupId)
           pure (gs, n)
         where
           countQuery' = countQuery <> " WHERE r.group_reg_status = ? "
-          orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
-      STRecent -> case lastGroup_ of
+      STRecent -> case cursor_ of
         Nothing -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> recentOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, pageSize)
           n <- count $ DB.query db countQuery' (Only GRSActive)
           pure (gs, n)
-        Just gId -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> orderBy <> " LIMIT ?") (userId, userContactId, GRSActive, gId, pageSize)
-          n <- count $ DB.query db (countQuery' <> " AND r.group_id > ?") (GRSActive, gId)
+        Just SearchCursor {lastCreatedAt, lastGroupId} -> do
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> recentCond <> recentOrderBy <> " LIMIT ?") (userId, userContactId, GRSActive, lastCreatedAt, lastCreatedAt, lastGroupId, pageSize)
+          n <- count $ DB.query db (countQuery' <> recentCond) (GRSActive, lastCreatedAt, lastCreatedAt, lastGroupId)
           pure (gs, n)
         where
           countQuery' = countQuery <> " WHERE r.group_reg_status = ? "
-          orderBy = " ORDER BY r.created_at DESC, r.group_reg_id ASC "
-      STSearch search -> case lastGroup_ of
+      STSearch search -> case cursor_ of
         Nothing -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> searchCond <> orderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, s, s, s, s) :. (sDomain, pageSize))
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> searchCond <> membersOrderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, s, s, s, s) :. (sDomain, pageSize))
           n <- count $ DB.query db (countQuery' <> searchCond) (GRSActive, s, s, s, s, sDomain)
           pure (gs, n)
-        Just gId -> do
-          gs <- groups currentTs $ DB.query db (listedGroupQuery <> " AND r.group_id > ? " <> searchCond <> orderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, gId, s, s, s, s) :. (sDomain, pageSize))
-          n <- count $ DB.query db (countQuery' <> " AND r.group_id > ? " <> searchCond) (GRSActive, gId, s, s, s, s, sDomain)
+        Just SearchCursor {lastMembers, lastGroupId} -> do
+          gs <- groups currentTs $ DB.query db (listedGroupQuery <> membersCond <> searchCond <> membersOrderBy <> " LIMIT ?") ((userId, userContactId, GRSActive, lastMembers, lastMembers, lastGroupId) :. (s, s, s, s, sDomain, pageSize))
+          n <- count $ DB.query db (countQuery' <> membersCond <> searchCond) ((GRSActive, lastMembers, lastMembers, lastGroupId) :. (s, s, s, s, sDomain))
           pure (gs, n)
         where
           s = T.toLower search
@@ -385,12 +383,17 @@ searchListedGroups cc user@User {userId, userContactId} searchType lastGroup_ pa
             Just (c, rest) | c == '#' || c == '@' -> if T.null rest then "#" else rest
             _ -> s
           countQuery' = countQuery <> " JOIN group_profiles gp ON gp.group_profile_id = g.group_profile_id WHERE r.group_reg_status = ? "
-          orderBy = " ORDER BY g.summary_current_members_count DESC, r.group_reg_id ASC "
   where
     groups currentTs = (map (toGroupInfoReg currentTs (storeCxt cc) user) <$>)
     count = maybeFirstRow' 0 fromOnly
     listedGroupQuery = groupReqQuery <> " AND r.group_reg_status = ? "
     countQuery = "SELECT COUNT(1) FROM groups g JOIN sx_directory_group_regs r ON g.group_id = r.group_id "
+    -- the cursor conditions must stay paired with the order by of the same sort key:
+    -- paging by any other column skips and repeats rows
+    membersOrderBy = " ORDER BY g.summary_current_members_count DESC, r.group_id ASC "
+    membersCond = " AND (g.summary_current_members_count < ? OR (g.summary_current_members_count = ? AND r.group_id > ?)) "
+    recentOrderBy = " ORDER BY r.created_at DESC, r.group_id ASC "
+    recentCond = " AND (r.created_at < ? OR (r.created_at = ? AND r.group_id > ?)) "
     searchCond =
       [sql|
         AND (LOWER(gp.display_name) LIKE '%' || ? || '%'

tests/Bots/DirectoryTests.hs

@@ -44,6 +44,7 @@ directoryServiceTests = do
   it "should join found group via link" testJoinGroup
   it "should support group names with spaces" testGroupNameWithSpaces
   it "should return more groups in search, all and recent groups" testSearchGroups
+  it "should page from the sort key, not group ID" testSearchGroupsPaging
   it "should invite to owners' group if specified" testInviteToOwnersGroup
   it "should re-invite owner who left owners' group" testInviteOwnerAfterLeavingOwnersGroup
   describe "de-listing the group" $ do
@@ -588,6 +589,68 @@ testSearchGroups ps =
       u <##. "Link to join the group "
       u <## (show count <> " members")
 
+-- Paging must continue from the sort key, not from group_id: here the last registered
+-- group has the most members, so it sorts first, and a group_id cursor would send it again.
+testSearchGroupsPaging :: HasCallStack => TestParams -> IO ()
+testSearchGroupsPaging ps =
+  withDirectoryService ps $ \superUser dsLink ->
+    withNewTestChat ps "bob" bobProfile $ \bob -> do
+      withNewTestChat ps "cath" cathProfile $ \cath -> do
+        bob `connectVia` dsLink
+        cath `connectVia` dsLink
+        forM_ [1 .. 4 :: Int] $ \i -> registerGroupId superUser bob (groups !! (i - 1)) "" i i
+        connectUsers bob cath
+        fullAddMember "groupD" "" bob cath GRMember
+        joinGroup "groupD" cath bob
+        cath <## "#groupD: member 'SimpleX Directory_1' is connected"
+        cath <## "contact and member are merged: 'SimpleX Directory', #groupD 'SimpleX Directory_1'"
+        cath <## "use @'SimpleX Directory' <message> to send messages"
+        -- /all: members desc, so groupD (3) precedes the groups registered before it
+        cath #> "@'SimpleX Directory' /all"
+        cath <# "'SimpleX Directory'> > /all"
+        cath <## "      4 group(s) listed, sending top 3."
+        receivedGroup cath 3 3
+        receivedGroup cath 0 2
+        receivedGroup cath 1 2
+        cath <# "'SimpleX Directory'> Send /next for 1 more result(s)."
+        cath #> "@'SimpleX Directory' /next"
+        cath <# "'SimpleX Directory'> > /next"
+        cath <## "      Sending 1 more group(s)."
+        receivedGroup cath 2 2
+        -- /new: created_at desc, in reverse registration order
+        cath #> "@'SimpleX Directory' /new"
+        cath <# "'SimpleX Directory'> > /new"
+        cath <## "      4 group(s) listed, sending the most recent 3."
+        receivedGroup cath 3 3
+        receivedGroup cath 2 2
+        receivedGroup cath 1 2
+        cath <# "'SimpleX Directory'> Send /next for 1 more result(s)."
+        cath #> "@'SimpleX Directory' /next"
+        cath <# "'SimpleX Directory'> > /next"
+        cath <## "      Sending 1 more group(s)."
+        receivedGroup cath 0 2
+        -- text search sorts as /all does
+        cath #> "@'SimpleX Directory' group"
+        cath <# "'SimpleX Directory'> > group"
+        cath <## "      Found 4 group(s), sending top 3."
+        receivedGroup cath 3 3
+        receivedGroup cath 0 2
+        receivedGroup cath 1 2
+        cath <# "'SimpleX Directory'> Send /next for 1 more result(s)."
+        cath #> "@'SimpleX Directory' /next"
+        cath <# "'SimpleX Directory'> > /next"
+        cath <## "      Sending 1 more group(s)."
+        receivedGroup cath 2 2
+  where
+    groups :: [String]
+    groups = ["groupA", "groupB", "groupC", "groupD"]
+    receivedGroup :: TestCC -> Int -> Int -> IO ()
+    receivedGroup u ix count = do
+      u <#. ("'SimpleX Directory'> " <> groups !! ix)
+      u <## "Welcome message:"
+      u <##. "Link to join the group "
+      u <## (show count <> " members")
+
 testInviteToOwnersGroup :: HasCallStack => TestParams -> IO ()
 testInviteToOwnersGroup ps =
   withDirectoryServiceCfgOwnersGroup ps testCfg True Nothing $ \superUser dsLink ->