From 9cc039915e8c04fb9b7500e0178f12b53918b1c0 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 15:18:18 -0600 Subject: [PATCH 1/4] Fetch package vote scores instead of every vote The all-packages votes endpoint only shows each package's score, so the votes store now returns scores rather than every user's vote. --- src/Distribution/Server/Features/Votes.hs | 9 ++++----- src/Distribution/Server/Features/Votes/Acid.hs | 2 +- src/Distribution/Server/Features/Votes/Store.hs | 2 +- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index b23761e8c..c4db6ebc6 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -14,8 +14,7 @@ import Distribution.Server.Features.Votes.Types (Score) import Distribution.Server.Features.Votes.Acid (acidStore) import qualified Distribution.Server.Features.Votes.Render as Render import Distribution.Server.Features.Votes.Store - ( votesScore - , Backend(..) + ( Backend(..) , Store(..) ) import Distribution.Server.Framework @@ -125,10 +124,10 @@ votesFeature ServerEnv{..} servePackageVotesGet :: DynamicPath -> ServerPartE Response servePackageVotesGet _ = do cacheControlWithoutETag [Public, maxAgeMinutes 10] - votesMap <- getAllPackageVoteSets votesState + scores <- getAllPackageVoteScores votesState ok . toResponse $ objectL - [ (display pkgname, toJSON (votesScore pkgMap)) - | (pkgname, pkgMap) <- Map.toList votesMap ] + [ (display pkgname, toJSON score) + | (pkgname, score) <- Map.toList scores ] -- Get the number of votes a package has. If the package -- has never been voted for, returns 0. diff --git a/src/Distribution/Server/Features/Votes/Acid.hs b/src/Distribution/Server/Features/Votes/Acid.hs index aa9ee0997..7b8eee354 100644 --- a/src/Distribution/Server/Features/Votes/Acid.hs +++ b/src/Distribution/Server/Features/Votes/Acid.hs @@ -16,7 +16,7 @@ acidStore stateDir = do votesState <- votesStateComponent stateDir return Backend { backendStore = Store { - getAllPackageVoteSets = queryState votesState Acid.GetAllPackageVoteSets + getAllPackageVoteScores = Map.map votesScore <$> queryState votesState Acid.GetAllPackageVoteSets , addVote = \pkgname uid score -> updateState votesState (Acid.AddVote pkgname uid score) , removeVote = \pkgname uid -> updateState votesState (Acid.RemoveVote pkgname uid) , getPackageVoteCount = \pkgname -> queryState votesState (Acid.GetPackageVoteCount pkgname) diff --git a/src/Distribution/Server/Features/Votes/Store.hs b/src/Distribution/Server/Features/Votes/Store.hs index 5cc87fd61..010b42cbf 100644 --- a/src/Distribution/Server/Features/Votes/Store.hs +++ b/src/Distribution/Server/Features/Votes/Store.hs @@ -24,7 +24,7 @@ data Backend = Backend { } data Store = Store { - getAllPackageVoteSets :: forall m. MonadIO m => m (Map.Map PackageName (Map.Map UserId Score)) + getAllPackageVoteScores :: forall m. MonadIO m => m (Map.Map PackageName Float) , addVote :: forall m. MonadIO m => PackageName -> UserId -> Score -> m Float , removeVote :: forall m. MonadIO m => PackageName -> UserId -> m Bool , getPackageVoteCount :: forall m. MonadIO m => PackageName -> m Int From 52ad9de5409b72fec829ff18e84a8909af21d464 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 15:19:45 -0600 Subject: [PATCH 2/4] Narrow tag store queries The tag listing and sitemap only need each tag's package count, and collectTags only needs the tags of the given packages, so the tags store returns those instead of every tag's packages or the whole tag map. --- src/Distribution/Server/Features/Html.hs | 4 ++-- src/Distribution/Server/Features/Sitemap.hs | 2 +- src/Distribution/Server/Features/Tags.hs | 11 +++++------ src/Distribution/Server/Features/Tags/Acid.hs | 10 ++++++++-- src/Distribution/Server/Features/Tags/Store.hs | 8 +++++--- 5 files changed, 21 insertions(+), 14 deletions(-) diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index 47f6b83db..f3e485111 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -1782,8 +1782,8 @@ mkHtmlTags HtmlUtilities{..} serveTagsListing :: DynamicPath -> ServerPartE Response serveTagsListing _ = do - tagList <- queryGetTagList - let withCounts = filter ((>0) . snd) . map (\(tg, pkgs) -> (tg, Set.size pkgs)) $ tagList + tagCounts <- queryTagCounts + let withCounts = filter ((>0) . snd) tagCounts countSort = sortBy (flip compare `on` snd) withCounts return $ toResponse $ Resource.XHtml $ hackagePage "Hackage tags" [ h2 << "Hackage tags" diff --git a/src/Distribution/Server/Features/Sitemap.hs b/src/Distribution/Server/Features/Sitemap.hs index 04fcc0cc1..a2cf95653 100644 --- a/src/Distribution/Server/Features/Sitemap.hs +++ b/src/Distribution/Server/Features/Sitemap.hs @@ -155,7 +155,7 @@ sitemapFeature ServerEnv{..} updateSitemapCache :: IO Sitemap updateSitemapCache = do - alltags <- queryGetTagList + alltags <- queryTagCounts pkgIndex <- queryGetPackageIndex docIndex <- queryDocumentationIndex diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index b9a6fa112..6e2a95d71 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -45,7 +45,8 @@ data TagsFeature = TagsFeature { tagsResource :: TagsResource, - queryGetTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)], + -- | Retrieves every tag with its number of packages, in tag order. + queryTagCounts :: forall m. MonadIO m => m [(Tag, Int)], queryTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag), queryReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag,Set Tag), queryAliasForTag :: forall m. MonadIO m => Tag -> m Tag, @@ -178,8 +179,8 @@ tagsFeature CoreFeature{ queryLatestPackages } let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag - queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)] - queryGetTagList = Store.getTagList tagsStore + queryTagCounts :: MonadIO m => m [(Tag, Int)] + queryTagCounts = Store.getTagCounts tagsStore queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag) queryTagsForPackage = Store.getTagsForPackage tagsStore @@ -204,9 +205,7 @@ tagsFeature CoreFeature{ queryLatestPackages } func tag pkgs collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)) - collectTags pkgs = do - pkgMap <- liftM State.packageTags $ Store.getPackageTags tagsStore - return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs + collectTags pkgs = Store.getTagsForPackages tagsStore (Set.toList pkgs) mergeTags :: Maybe String -> Tag -> ServerPartE () mergeTags targetTag deprTag = diff --git a/src/Distribution/Server/Features/Tags/Acid.hs b/src/Distribution/Server/Features/Tags/Acid.hs index 14995306a..2b2a0e125 100644 --- a/src/Distribution/Server/Features/Tags/Acid.hs +++ b/src/Distribution/Server/Features/Tags/Acid.hs @@ -10,18 +10,24 @@ import Distribution.Server.Features.Tags.Backup import Distribution.Server.Framework import Distribution.Server.Framework.BackupDump +import qualified Data.Map as Map +import qualified Data.Set as Set + acidStore :: FilePath -> IO Store.Backend acidStore stateDir = do tagsState <- tagsStateComponent stateDir tagAlias <- tagsAliasComponent stateDir pure Store.Backend { Store.backendStore = Store.Store { - Store.getTagList = queryState tagsState State.GetTagList + Store.getTagCounts = map (fmap Set.size) <$> queryState tagsState State.GetTagList , Store.getTagsForPackage = \pkgname -> queryState tagsState (State.TagsForPackage pkgname) , Store.getReviewTagsForPackage = \pkgname -> queryState tagsState (State.LookupReviewTags pkgname) , Store.getTagAlias = \tag -> queryState tagAlias (State.GetTagAlias tag) , Store.getPackagesForTag = \tag -> queryState tagsState (State.PackagesForTag tag) - , Store.getPackageTags = queryState tagsState State.GetPackageTags + , Store.getTagsForPackages = \pkgnames -> do + pkgTags <- State.packageTags <$> queryState tagsState State.GetPackageTags + pure $ Map.fromList + [ (pkgname, Map.findWithDefault Set.empty pkgname pkgTags) | pkgname <- pkgnames ] , Store.setPackageTags = \pkgname tags -> updateState tagsState (State.SetPackageTags pkgname tags) , Store.setTagPackages = \tag pkgs -> updateState tagsState (State.SetTagPackages tag pkgs) , Store.addTagAlias = \tag alias -> updateState tagAlias (State.AddTagAlias tag alias) diff --git a/src/Distribution/Server/Features/Tags/Store.hs b/src/Distribution/Server/Features/Tags/Store.hs index d303b0668..4988efcda 100644 --- a/src/Distribution/Server/Features/Tags/Store.hs +++ b/src/Distribution/Server/Features/Tags/Store.hs @@ -6,11 +6,11 @@ module Distribution.Server.Features.Tags.Store ) where import Distribution.Package (PackageName) -import Distribution.Server.Features.Tags.State (PackageTags) import Distribution.Server.Features.Tags.Types (Tag) import Distribution.Server.Framework (AbstractStateComponent) import Control.Monad.Trans (MonadIO) +import Data.Map (Map) import Data.Set (Set) data Backend = Backend { @@ -19,12 +19,14 @@ data Backend = Backend { } data Store = Store { - getTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)] + -- | Every tag with its number of packages, in tag order. + getTagCounts :: forall m. MonadIO m => m [(Tag, Int)] , getTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag) , getReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag, Set Tag) , getTagAlias :: forall m. MonadIO m => Tag -> m Tag , getPackagesForTag :: forall m. MonadIO m => Tag -> m (Set PackageName) - , getPackageTags :: forall m. MonadIO m => m PackageTags + -- | The tags of each given package, including packages with none. + , getTagsForPackages :: forall m. MonadIO m => [PackageName] -> m (Map PackageName (Set Tag)) , setPackageTags :: forall m. MonadIO m => PackageName -> Set Tag -> m () , setTagPackages :: forall m. MonadIO m => Tag -> Set PackageName -> m () , addTagAlias :: forall m. MonadIO m => Tag -> Tag -> m () From d5995518620124263479cb27a0750ec2f6217a25 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 15:21:04 -0600 Subject: [PATCH 3/4] Split the preferred versions store getter Callers fetched the whole PreferredVersions value to use only the preferred version map, only the deprecations, or only the migration flag. The preferred versions store now returns each separately. --- .../Server/Features/PreferredVersions.hs | 24 +++++++++---------- .../Server/Features/PreferredVersions/Acid.hs | 4 +++- .../Features/PreferredVersions/Store.hs | 7 ++++-- .../Server/Features/ReverseDependencies.hs | 11 ++++----- .../Features/ReverseDependencies/State.hs | 4 ++-- tests/ReverseDependenciesTest.hs | 10 ++------ 6 files changed, 29 insertions(+), 31 deletions(-) diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index e86b54d18..4c4194fb5 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -57,7 +57,7 @@ data VersionsFeature = VersionsFeature { queryGetPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo, queryGetDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName]), - queryGetPreferredVersions :: forall m. MonadIO m => m PreferredVersions, + queryAllPreferredInfo :: forall m. MonadIO m => m (Map.Map PackageName PreferredInfo), versionsResource :: VersionsResource, deprecatedHook :: Hook (PackageName, Maybe [PackageName]) (), @@ -158,11 +158,11 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName]) queryGetDeprecatedFor = Store.getDeprecatedFor preferredStore - queryGetPreferredVersions :: MonadIO m => m PreferredVersions - queryGetPreferredVersions = Store.getPreferredVersions preferredStore + queryAllPreferredInfo :: MonadIO m => m (Map.Map PackageName PreferredInfo) + queryAllPreferredInfo = Store.getAllPreferredInfo preferredStore updateDeprecatedTags = do - pkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore + pkgs <- Store.getAllDeprecated preferredStore setCalculatedTag (Tag "deprecated") (Map.keysSet pkgs) CoreResource{..} = coreResource @@ -212,7 +212,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response handlePackagesDeprecatedGet _ = do - deprPkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore + deprPkgs <- Store.getAllDeprecated preferredStore return $ toResponse $ array [ object [ ("deprecated-package", string $ display deprPkg) @@ -387,16 +387,16 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } Store.getDeprecatedFor preferredStore pkgname doPreferredsRender :: MonadIO m => m [(PackageName, PreferredRender)] - doPreferredsRender = Store.getPreferredVersions preferredStore >>= - return . map (second renderPrefInfo) . Map.toList . preferredMap + doPreferredsRender = Store.getAllPreferredInfo preferredStore >>= + return . map (second renderPrefInfo) . Map.toList doDeprecatedsRender :: MonadIO m => m [(PackageName, [PackageName])] - doDeprecatedsRender = Store.getPreferredVersions preferredStore >>= - return . Map.toList . deprecatedMap + doDeprecatedsRender = Store.getAllDeprecated preferredStore >>= + return . Map.toList makeGlobalPreferredVersions :: (Functor m, MonadIO m) => m String makeGlobalPreferredVersions = do - prefs <- preferredMap <$> Store.getPreferredVersions preferredStore + prefs <- Store.getAllPreferredInfo preferredStore return $! formatGlobalPreferredVersions (Map.toList prefs) formatSinglePreferredVersions :: PackageName -> PreferredInfo -> Maybe String @@ -422,10 +422,10 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } -- One-off complex migration ephemeralPrefsMigration = do - PreferredVersions {migratedEphemeralPrefs, preferredMap} - <- Store.getPreferredVersions preferredStore + migratedEphemeralPrefs <- Store.isMigratedEphemeralPrefs preferredStore unless migratedEphemeralPrefs $ logTiming verbosity "preferred-versions migration" $ do + preferredMap <- Store.getAllPreferredInfo preferredStore sequence_ [ updateIndexPackagePreferredVersions pkgname prefinfo | (pkgname, prefinfo) <- Map.toList preferredMap ] diff --git a/src/Distribution/Server/Features/PreferredVersions/Acid.hs b/src/Distribution/Server/Features/PreferredVersions/Acid.hs index a96406242..9ca4847bd 100644 --- a/src/Distribution/Server/Features/PreferredVersions/Acid.hs +++ b/src/Distribution/Server/Features/PreferredVersions/Acid.hs @@ -15,7 +15,9 @@ acidStore stateDir = do Store.backendStore = Store.Store { Store.getPreferredInfo = \name -> queryState preferredState (State.GetPreferredInfo name) , Store.getDeprecatedFor = \name -> queryState preferredState (State.GetDeprecatedFor name) - , Store.getPreferredVersions = queryState preferredState State.GetPreferredVersions + , Store.getAllPreferredInfo = State.preferredMap <$> queryState preferredState State.GetPreferredVersions + , Store.getAllDeprecated = State.deprecatedMap <$> queryState preferredState State.GetPreferredVersions + , Store.isMigratedEphemeralPrefs = State.migratedEphemeralPrefs <$> queryState preferredState State.GetPreferredVersions , Store.setDeprecatedFor = \name deprs -> updateState preferredState (State.SetDeprecatedFor name deprs) , Store.setPreferredInfo = \name ranges versions -> updateState preferredState (State.SetPreferredInfo name ranges versions) , Store.setMigratedEphemeralPrefs = updateState preferredState State.SetMigratedEphemeralPrefs diff --git a/src/Distribution/Server/Features/PreferredVersions/Store.hs b/src/Distribution/Server/Features/PreferredVersions/Store.hs index e49450f60..8a6f6e50e 100644 --- a/src/Distribution/Server/Features/PreferredVersions/Store.hs +++ b/src/Distribution/Server/Features/PreferredVersions/Store.hs @@ -6,11 +6,12 @@ module Distribution.Server.Features.PreferredVersions.Store ) where import Distribution.Package (PackageName) -import Distribution.Server.Features.PreferredVersions.State (PreferredInfo, PreferredVersions) +import Distribution.Server.Features.PreferredVersions.State (PreferredInfo) import Distribution.Server.Framework (AbstractStateComponent) import Distribution.Version (Version, VersionRange) import Control.Monad.Trans (MonadIO) +import Data.Map (Map) data Backend = Backend { backendStore :: Store @@ -20,7 +21,9 @@ data Backend = Backend { data Store = Store { getPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo , getDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName]) - , getPreferredVersions :: forall m. MonadIO m => m PreferredVersions + , getAllPreferredInfo :: forall m. MonadIO m => m (Map PackageName PreferredInfo) + , getAllDeprecated :: forall m. MonadIO m => m (Map PackageName [PackageName]) + , isMigratedEphemeralPrefs :: forall m. MonadIO m => m Bool , setDeprecatedFor :: forall m. MonadIO m => PackageName -> Maybe [PackageName] -> m () , setPreferredInfo :: forall m. MonadIO m => PackageName -> [VersionRange] -> [Version] -> m PreferredInfo , setMigratedEphemeralPrefs :: forall m. MonadIO m => m () diff --git a/src/Distribution/Server/Features/ReverseDependencies.hs b/src/Distribution/Server/Features/ReverseDependencies.hs index 2bdbe1ac2..0df3b656c 100644 --- a/src/Distribution/Server/Features/ReverseDependencies.hs +++ b/src/Distribution/Server/Features/ReverseDependencies.hs @@ -12,7 +12,6 @@ module Distribution.Server.Features.ReverseDependencies ( import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.PreferredVersions -import Distribution.Server.Features.PreferredVersions.State (PreferredVersions) import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.PackageIndex (PackageIndex, packageNames, allPackagesByNameNE) import Distribution.Server.Packages.Types (PkgInfo) @@ -84,11 +83,11 @@ initReverseFeature _ = do updateReverse <- newHook return $ \CoreFeature{queryGetPackageIndex,packageChangeHook} - VersionsFeature{queryGetPreferredVersions} -> do + VersionsFeature{queryAllPreferredInfo} -> do idx <- queryGetPackageIndex memState <- newMemStateWHNF $ constructReverseIndex idx - let feature = reverseFeature queryGetPackageIndex queryGetPreferredVersions memState updateReverse + let feature = reverseFeature queryGetPackageIndex queryAllPreferredInfo memState updateReverse registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) -> case mpkginfo of @@ -125,13 +124,13 @@ instance ToJSON Edge -- instance ToJSON PackageName reverseFeature :: IO (PackageIndex PkgInfo) - -> IO PreferredVersions + -> IO (Map.Map PackageName PreferredInfo) -> MemState ReverseIndex -> Hook [NE.NonEmpty PkgInfo] () -> ReverseFeature reverseFeature queryGetPackageIndex - queryGetPreferredVersions + queryAllPreferredInfo reverseMemState reverseHook = ReverseFeature{..} @@ -211,7 +210,7 @@ reverseFeature queryGetPackageIndex revDisplayInfo :: MonadIO m => m VersionIndex revDisplayInfo = do pkgIndex <- liftIO queryGetPackageIndex - prefs <- liftIO queryGetPreferredVersions + prefs <- liftIO queryAllPreferredInfo return $ getDisplayInfo prefs pkgIndex renderReverseWith :: MonadIO m => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool) -> m ReversePageRender diff --git a/src/Distribution/Server/Features/ReverseDependencies/State.hs b/src/Distribution/Server/Features/ReverseDependencies/State.hs index a8345fe3f..781981f25 100644 --- a/src/Distribution/Server/Features/ReverseDependencies/State.hs +++ b/src/Distribution/Server/Features/ReverseDependencies/State.hs @@ -181,9 +181,9 @@ constructReverseDisplay :: (PackageName -> (PreferredInfo, [Version])) -> Map Pa constructReverseDisplay indexFunc = Map.mapMaybeWithKey (uncurry maybeBestVersion . indexFunc) -getDisplayInfo :: PreferredVersions -> PackageIndex PkgInfo -> VersionIndex +getDisplayInfo :: Map PackageName PreferredInfo -> PackageIndex PkgInfo -> VersionIndex getDisplayInfo preferred index pkgname = (,) - (Map.findWithDefault emptyPreferredInfo pkgname $ preferredMap preferred) + (Map.findWithDefault emptyPreferredInfo pkgname preferred) (map packageVersion . PackageIndex.lookupPackageName index $ pkgname) diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index b536633eb..88b03cf76 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -23,7 +23,7 @@ import Network.URI (parseURI) import System.Random (mkStdGen) import Distribution.Package (PackageIdentifier(..), mkPackageName, packageId, packageName) -import Distribution.Server.Features.PreferredVersions.State (PreferredVersions(..), PreferredInfo(..)) +import Distribution.Server.Features.PreferredVersions.State (PreferredInfo(..)) import Distribution.Server.Features.PreferredVersions.Types (VersionStatus(NormalVersion)) import Distribution.Server.Features.ReverseDependencies (ReverseFeature(..), ReverseCount(..), reverseFeature) import Distribution.Server.Features.ReverseDependencies.State (ReverseIndex(..), addPackage, constructReverseIndex, emptyReverseIndex, getDependenciesFlat, getDependencies, getDependenciesFlatRaw, getDependenciesRaw) @@ -123,19 +123,13 @@ mkRevFeat :: [PkgInfo] -> IO ReverseFeature mkRevFeat pkgs = do let idx = PackageIndex.fromList pkgs - preferredVersions = - PreferredVersions - { preferredMap = mempty - , deprecatedMap = mempty - , migratedEphemeralPrefs = False - } updateReverse <- newHook let constructed = constructReverseIndex idx memState <- newMemStateWHNF constructed pure $ reverseFeature (pure idx) - (pure preferredVersions) + (pure mempty) memState updateReverse From 6e8e1047886864c194d8bf4d573c9836fbff4a78 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 15:49:20 -0600 Subject: [PATCH 4/4] Look up single candidates instead of the whole candidate index Candidate pages look up a package's candidates or one candidate version with new candidates store queries. Listings read all candidates as a list, so the store no longer exposes its index. --- src/Distribution/Server/Features/PackageCandidates.hs | 11 +++++------ .../Server/Features/PackageCandidates/Acid.hs | 8 +++++++- .../Server/Features/PackageCandidates/Store.hs | 5 +++-- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index dfc9a9849..fb4329977 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -145,7 +145,7 @@ initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do -- one-off migration migratedPkgTarball <- Store.candidateTarballIsMigrated candidatesStore unless migratedPkgTarball $ do - candidateIndex <- Store.getCandidateIndex candidatesStore + candidateIndex <- PackageIndex.fromList <$> Store.allCandidates candidatesStore migrateCandidatePkgTarball_v1_to_v2 env candidateIndex $ \pkgid pkginfo -> void $ Store.updateCandidatePkgInfo candidatesStore pkgid pkginfo Store.setCandidateTarballMigrated candidatesStore @@ -195,7 +195,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} } queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo) - queryGetCandidateIndex = Store.getCandidateIndex candidatesStore + queryGetCandidateIndex = PackageIndex.fromList <$> Store.allCandidates candidatesStore candidatesCoreResource = fix $ \r -> CoreResource { -- TODO: There is significant overlap between this definition and the one in Core @@ -541,8 +541,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo] lookupCandidateName pkgname = do guardValidPackageName core pkgname - candidateIndex <- queryGetCandidateIndex - return $ PackageIndex.lookupPackageName candidateIndex pkgname + Store.lookupCandidateName candidatesStore pkgname -- TODO: Unlike the corresponding function in core, we don't return the -- "latest" candidate when Version is empty. Should we? @@ -550,8 +549,8 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo lookupCandidateId pkgid = do guard (pkgVersion pkgid /= nullVersion) - candidateIndex <- queryGetCandidateIndex - case PackageIndex.lookupPackageId candidateIndex pkgid of + mcand <- Store.lookupCandidateId candidatesStore pkgid + case mcand of Just pkg -> return pkg _ -> errNotFound "Candidate not found" [MText $ "No such candidate version for " ++ display (packageName pkgid)] diff --git a/src/Distribution/Server/Features/PackageCandidates/Acid.hs b/src/Distribution/Server/Features/PackageCandidates/Acid.hs index 5a26e6c1d..a3adc9b3d 100644 --- a/src/Distribution/Server/Features/PackageCandidates/Acid.hs +++ b/src/Distribution/Server/Features/PackageCandidates/Acid.hs @@ -7,13 +7,19 @@ import qualified Distribution.Server.Features.PackageCandidates.State as State import Distribution.Server.Features.PackageCandidates.Backup import qualified Distribution.Server.Features.PackageCandidates.Store as Store import Distribution.Server.Framework +import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo) +import qualified Distribution.Server.Packages.PackageIndex as PackageIndex acidStore :: FilePath -> IO Store.Backend acidStore stateDir = do candidatesState <- candidatesStateComponent False stateDir + let withCandidates :: MonadIO m => (PackageIndex.PackageIndex CandPkgInfo -> a) -> m a + withCandidates f = f . State.candidateList <$> queryState candidatesState State.GetCandidatePackages pure Store.Backend { Store.backendStore = Store.Store { - Store.getCandidateIndex = State.candidateList <$> queryState candidatesState State.GetCandidatePackages + Store.lookupCandidateName = \pkgname -> withCandidates (`PackageIndex.lookupPackageName` pkgname) + , Store.lookupCandidateId = \pkgid -> withCandidates (`PackageIndex.lookupPackageId` pkgid) + , Store.allCandidates = withCandidates PackageIndex.allPackages , Store.candidateTarballIsMigrated = State.candidateMigratedPkgTarball <$> queryState candidatesState State.GetCandidatePackages , Store.setCandidateTarballMigrated = updateState candidatesState State.SetMigratedPkgTarball , Store.addCandidate = \candidate -> updateState candidatesState (State.AddCandidate candidate) diff --git a/src/Distribution/Server/Features/PackageCandidates/Store.hs b/src/Distribution/Server/Features/PackageCandidates/Store.hs index 461d67f35..d9bc0d28d 100644 --- a/src/Distribution/Server/Features/PackageCandidates/Store.hs +++ b/src/Distribution/Server/Features/PackageCandidates/Store.hs @@ -8,7 +8,6 @@ module Distribution.Server.Features.PackageCandidates.Store import Distribution.Package (PackageId, PackageName) import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo) import Distribution.Server.Framework (AbstractStateComponent) -import Distribution.Server.Packages.PackageIndex (PackageIndex) import Distribution.Server.Packages.Types (PkgInfo) import Control.Monad.Trans (MonadIO) @@ -19,7 +18,9 @@ data Backend = Backend { } data Store = Store { - getCandidateIndex :: forall m. MonadIO m => m (PackageIndex CandPkgInfo) + lookupCandidateName :: forall m. MonadIO m => PackageName -> m [CandPkgInfo] + , lookupCandidateId :: forall m. MonadIO m => PackageId -> m (Maybe CandPkgInfo) + , allCandidates :: forall m. MonadIO m => m [CandPkgInfo] , candidateTarballIsMigrated :: forall m. MonadIO m => m Bool , setCandidateTarballMigrated :: forall m. MonadIO m => m () , addCandidate :: forall m. MonadIO m => CandPkgInfo -> m ()