diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs index cb928dce9c..bbabdabe91 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs @@ -102,16 +102,20 @@ searchAnswer NamesConfig {nTLD, nYears, nTermStart, nChain = ChainConfig {cChain recordsJSON NameRecords {rdContact, rdChannel} = J.object ["contact" .= rdContact, "channel" .= rdChannel] -- | Contact entities first. A record may hold several links joined as the app joins them; a value that is not --- a short link of its record's kind makes no entity. +-- a short link of its record's kind makes no entity, and neither does a link past the first few of its kind. recordEntities :: Profiles -> NameRecords -> IO [Entity] recordEntities ps NameRecords {rdContact, rdChannel} = mapConcurrently (uncurry $ linkEntity ps) $ recordLinks LKContact rdContact <> recordLinks LKChannel rdChannel where - recordLinks kind = map (kind,) . filter ((Just kind ==) . linkKindOf) . map T.strip . T.splitOn linkSeparator + recordLinks kind = map (kind,) . take maxEntitiesPerKey . filter ((Just kind ==) . linkKindOf) . map T.strip . T.splitOn linkSeparator linkSeparator :: Text linkSeparator = ";" +-- | The links of a record beyond these are not fetched, so a record cannot grow a search's fetches and answer. +maxEntitiesPerKey :: Int +maxEntitiesPerKey = 5 + -- | A link whose profile cannot be read is still a valid link: only its kind decides. previewHandler :: Profiles -> Request -> Respond -> IO ResponseReceived previewHandler ps req respond = diff --git a/tests/Bots/StoreService/NamesSearchTests.hs b/tests/Bots/StoreService/NamesSearchTests.hs index b41ddf1cc7..0c4735f75a 100644 --- a/tests/Bots/StoreService/NamesSearchTests.hs +++ b/tests/Bots/StoreService/NamesSearchTests.hs @@ -71,6 +71,7 @@ namesSearchTests = describe "StoreService names: search" $ do it "answers a name the chain has available as registered while its register here is sent, without a price" $ testRegistering g it "answers a registered name with its entities, raw records, owner, resolver, nonce, expiry and grace period" $ testRegistered g it "makes one entity per short link of its record's kind, splitting on ';', and none from other values" $ testRecordLinks g + it "makes entities of the first 5 short links of a record only, fetching no other" $ testRecordLinksCap g it "reads no records from another resolver" $ testOtherResolver g it "answers a link whose profile was not read unread, and a private host's unavailable without fetching it" $ testEntityProfiles g it "answers provider_unavailable to any failed chain read, records and price included" $ testFailedReads g @@ -347,6 +348,16 @@ testRecordLinks g = withSearch g id $ \s@Search {node} -> do registeredWith node fullLink "" searchAlice s 12 `shouldReturn` registeredAnswer [] (recordsOf fullLink "") resolverText (J.toJSON (0 :: Int)) +testRecordLinksCap :: TVar ChaChaDRG -> IO () +testRecordLinksCap g = withSearch g id $ \s@Search {node} -> do + let contacts = map (\n -> taggedLink "smp8.simplex.im" 'a' ("Bot" <> T.pack (show n))) [1 .. 7 :: Int] + -- a value of another kind first, so the cap counts only the record's own links + registeredWith node (T.intercalate ";" $ newsLink : contacts) newsLink + answer <- searchAlice s 12 + entitySummaries answer + `shouldBe` map ("address", "bot", "ok",) (take 5 contacts) <> [("channel", "channel", "ok", newsLink)] + length . filter (T.isInfixOf "#Bot") <$> fetchedLinks s `shouldReturn` 5 + testOtherResolver :: TVar ChaChaDRG -> IO () testOtherResolver g = withSearch g id $ \s@Search {node} -> do nameState node (toInteger $ now + year) 0