From baa98ad7860167182ed99045a75348b4b4c7149c Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 14:20:43 -0600 Subject: [PATCH] Batch per-package queries in notifications and deprecation - The notification job collects documentation reports with a new queryReportsBetween build reports query instead of querying the reports of every package, and looks up the latest versions of recently uploaded packages in one batch. - putDeprecated checks that all superseding packages exist in one batch. A new queryLookupPackageNames core query serves both batches. --- .../Server/Features/BuildReports.hs | 8 ++++ .../Server/Features/BuildReports/Acid.hs | 11 +++++ .../Server/Features/BuildReports/Store.hs | 4 ++ src/Distribution/Server/Features/Core.hs | 8 ++++ src/Distribution/Server/Features/Core/Acid.hs | 6 +++ .../Server/Features/Core/Store.hs | 3 ++ .../Server/Features/PreferredVersions.hs | 4 +- .../Server/Features/UserNotify.hs | 40 ++++++++++--------- 8 files changed, 64 insertions(+), 20 deletions(-) diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index f4fb58f88..68cd0b3fd 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -14,6 +14,8 @@ import Distribution.Server.Features.Core import qualified Distribution.Server.Features.BuildReports.Acid as Acid import qualified Distribution.Server.Features.BuildReports.Store as Store + +import Data.Time.Clock (UTCTime) import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..)) import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..)) @@ -44,6 +46,9 @@ data ReportsFeature = ReportsFeature { packageReport :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog), queryPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)], + -- | Retrieves the reports whose time is after the first time and no later + -- than the second, in package id order. + queryReportsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)], queryBuildLog :: forall m. MonadIO m => BuildLog -> m Resource.BuildLog, queryTestLog :: forall m. MonadIO m => TestLog -> m Resource.TestLog, queryTestReportLog :: forall m. MonadIO m => TestReportLog -> m Resource.TestReportLog, @@ -206,6 +211,9 @@ buildReportsFeature name queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] queryPackageReports = Store.lookupPackageReports reportsStore + queryReportsBetween :: MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)] + queryReportsBetween = Store.reportsBetween reportsStore + queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog queryBuildLog (BuildLog blobId) = do file <- liftIO $ BlobStorage.fetch store blobId diff --git a/src/Distribution/Server/Features/BuildReports/Acid.hs b/src/Distribution/Server/Features/BuildReports/Acid.hs index 0bbe2aa18..1ca4e948b 100644 --- a/src/Distribution/Server/Features/BuildReports/Acid.hs +++ b/src/Distribution/Server/Features/BuildReports/Acid.hs @@ -6,9 +6,12 @@ module Distribution.Server.Features.BuildReports.Acid import qualified Distribution.Server.Features.BuildReports.State as State import Distribution.Server.Features.BuildReports.Backup (dumpBackup, restoreBackup) import Distribution.Server.Features.BuildReports.BuildReports (BuildReports) +import qualified Distribution.Server.Features.BuildReports.BuildReports as BuildReports import qualified Distribution.Server.Features.BuildReports.Store as Store import Distribution.Server.Framework +import qualified Data.Map as Map + acidStore :: String -> FilePath -> IO Store.Backend acidStore name stateDir = do reportsState <- reportsStateComponent name stateDir @@ -18,6 +21,14 @@ acidStore name stateDir = do , Store.lookupPackageReports = \pkgid -> do reports <- queryState reportsState (State.LookupPackageReports pkgid) pure $ map (\(reportId, (report, _, _, _)) -> (reportId, report)) reports + , Store.reportsBetween = \earlier later -> do + buildReports <- queryState reportsState State.GetBuildReports + pure [ (pkgid, report) + | (pkgid, pkgReports) <- Map.toList (BuildReports.reportsIndex buildReports) + , (report, _, _, _, _) <- Map.elems (BuildReports.reports pkgReports) + , Just t <- [BuildReports.time report] + , t > earlier && t <= later + ] , Store.lookupFailCount = \pkgid -> queryState reportsState (State.LookupFailCount pkgid) , Store.lookupLatestReport = \pkgid -> queryState reportsState (State.LookupLatestReport pkgid) , Store.lookupRunTests = \pkgid -> queryState reportsState (State.LookupRunTests pkgid) diff --git a/src/Distribution/Server/Features/BuildReports/Store.hs b/src/Distribution/Server/Features/BuildReports/Store.hs index 197b06583..c8ac89366 100644 --- a/src/Distribution/Server/Features/BuildReports/Store.hs +++ b/src/Distribution/Server/Features/BuildReports/Store.hs @@ -12,6 +12,7 @@ import Distribution.Server.Features.BuildReports.BuildReports import Distribution.Server.Framework (AbstractStateComponent) import Control.Monad.Trans (MonadIO) +import Data.Time.Clock (UTCTime) data Backend = Backend { backendStore :: Store @@ -21,6 +22,9 @@ data Backend = Backend { data Store = Store { lookupReportCovg :: forall m. MonadIO m => PackageId -> BuildReportId -> m (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) , lookupPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] + -- | Reports whose time is after the first time and no later than the + -- second, in package id order. + , reportsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)] , lookupFailCount :: forall m. MonadIO m => PackageId -> m (Maybe BuildStatus) , lookupLatestReport :: forall m. MonadIO m => PackageId -> m (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) , lookupRunTests :: forall m. MonadIO m => PackageId -> m Bool diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 2dc28cd8b..920469f87 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -25,6 +25,7 @@ import qualified Codec.Compression.GZip as GZip import Data.Aeson (Value (..), toJSON) import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KeyMap +import Data.Map (Map) import Data.ByteString.Lazy (LazyByteString, fromStrict) import qualified Data.Foldable as Foldable import qualified Data.Text as Text @@ -79,6 +80,10 @@ data CoreFeature = CoreFeature { -- | Retrieves a specific package version. queryLookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo), + -- | Retrieves all versions of the given packages, leaving out names that + -- do not exist. + queryLookupPackageNames :: forall m. MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo]), + -- | Retrieves the latest version of every package. queryLatestPackages :: forall m. MonadIO m => m [PkgInfo], @@ -516,6 +521,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} queryLookupPackageId :: MonadIO m => PackageId -> m (Maybe PkgInfo) queryLookupPackageId = Store.lookupPackageId packagesStore + queryLookupPackageNames :: MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo]) + queryLookupPackageNames = Store.lookupPackageNames packagesStore + queryLatestPackages :: MonadIO m => m [PkgInfo] queryLatestPackages = Store.latestPackages packagesStore diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs index 2d7767f87..31cc5fba9 100644 --- a/src/Distribution/Server/Features/Core/Acid.hs +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -14,6 +14,7 @@ import Distribution.Server.Packages.Types (PkgInfo, pkgLatestUploadTime) import Distribution.Package (packageId) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend acidStore env verbosity freshDB stateDir = do @@ -25,6 +26,11 @@ acidStore env verbosity freshDB stateDir = do getPackagesState = queryState packagesState Acid.GetPackagesState , lookupPackageName = \pkgname -> withIndex (`PackageIndex.lookupPackageName` pkgname) , lookupPackageId = \pkgid -> withIndex (`PackageIndex.lookupPackageId` pkgid) + , lookupPackageNames = \pkgnames -> withIndex $ \index -> + Map.fromList [ (pkgname, pkgs) + | pkgname <- pkgnames + , let pkgs = PackageIndex.lookupPackageName index pkgname + , not (null pkgs) ] , latestPackages = withIndex (map NE.last . PackageIndex.allPackagesByNameNE) , allPackageNames = withIndex PackageIndex.allPackageNames , allPackageIds = withIndex (map packageId . PackageIndex.allPackages) diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs index 56c23787a..4bee9daf3 100644 --- a/src/Distribution/Server/Features/Core/Store.hs +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -15,6 +15,7 @@ import Distribution.Server.Users.Users (Users) import Distribution.Package (PackageId, PackageName) import Control.Monad.Trans (MonadIO) +import Data.Map (Map) import Data.Time.Clock (UTCTime) data Backend = Backend { @@ -26,6 +27,8 @@ data Store = Store { getPackagesState :: forall m. MonadIO m => m PackagesState , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] , lookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) + -- | The given packages that exist, with all their versions. + , lookupPackageNames :: forall m. MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo]) , latestPackages :: forall m. MonadIO m => m [PkgInfo] -- | Every package name, in ascending order. , allPackageNames :: forall m. MonadIO m => m [PackageName] diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index 4c4194fb5..85512d35c 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -350,7 +350,9 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } Just {} -> do depr <- optional $ fmap words $ look "by" case mapM simpleParse =<< depr of - Just deprs -> filterM (fmap null . queryLookupPackageName) deprs >>= \case + Just deprs -> do + existing <- queryLookupPackageNames deprs + case filter (`Map.notMember` existing) deprs of [] -> case pkgname `elem` deprs of True -> deprecatedError "You can not deprecate a package in favor of itself!" _ -> do diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index ad4436440..091ec930c 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -67,7 +67,7 @@ import Data.Bimap (lookup, lookupR) import Data.Graph (Vertex) import Data.Hashable (Hashable(..)) import Data.List (maximumBy, sortOn) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Ord (Down(..), comparing) import Data.Time (addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime) import Distribution.Text (display) @@ -482,7 +482,8 @@ userNotifyFeature UserFeature{..} then addUTCTime (negate $ (60*60*6)) now else lastNotifyTime -- for testing you can increase this revisionsAndUploads <- queryLatestUploadsBetween trimLastTime now - revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads + uploadedPackages <- queryLookupPackageNames (map (packageName . pkgInfoId) revisionsAndUploads) + revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs uploadedPackages trimLastTime now) revisionsAndUploads groupActions <- collectAdminActions trimLastTime now groupActionNotifications <- concatMapM (genGroupUploadList notifyPrefs) groupActions @@ -521,27 +522,28 @@ userNotifyFeature UserFeature{..} return $ filter isRecent $ aLog collectDocReport earlier now = do - pkgs <- PackageIndex.allPackages <$> queryGetPackageIndex - pkgRpts <- forM pkgs $ \pkg -> do - rpts <- queryPackageReports (packageId pkg) - pure $ (pkg,) $ do - -- List monad, filter out recent docbuilds - (_, rpt@BuildReport.BuildReport{..}) <- rpts - t <- maybeToList time - guard $ docsOutcome /= BuildReport.NotTried && t > earlier && t <= now - pure rpt - let isBuildOk BuildReport.BuildReport{..} = docsOutcome == BuildReport.Ok - pure $ map (second (all isBuildOk)) $ filter (not . Prelude.null . snd) pkgRpts + rpts <- queryReportsBetween earlier now + let docRpts = Map.fromListWith (flip (++)) + [ (pkgid, [rpt]) + | (pkgid, rpt) <- rpts + , BuildReport.docsOutcome rpt /= BuildReport.NotTried + ] + isBuildOk rpt = BuildReport.docsOutcome rpt == BuildReport.Ok + indexedPackages <- queryLookupPackageNames (map packageName (Map.keys docRpts)) + let isInMainIndex pkgid = + any ((== pkgid) . pkgInfoId) (Map.findWithDefault [] (packageName pkgid) indexedPackages) + pure $ filter (isInMainIndex . fst) $ + map (second (all isBuildOk)) (Map.toList docRpts) collectTagProposals = do logs <- readMemState tagProposalLog writeMemState tagProposalLog Map.empty pure $ Map.toList logs - genRevUploadList notifyPrefs earlier now pkg = do + genRevUploadList notifyPrefs uploadedPackages earlier now pkg = do let pkgName = packageName . pkgInfoId $ pkg - allVersions <- queryLookupPackageName pkgName - let actor = pkgLatestUploadUser pkg + allVersions = Map.findWithDefault [] pkgName uploadedPackages + actor = pkgLatestUploadUser pkg isRevision = pkgNumRevisions pkg > 1 mbLatest = listToMaybe (reverse allVersions) isLatestVersion = maybe False (\x -> pkgInfoId pkg == pkgInfoId x) mbLatest @@ -601,8 +603,8 @@ userNotifyFeature UserFeature{..} } _ -> pure [] - genDocReportList notifyPrefs (pkg, success) = do - maintainers <- queryUserGroup $ maintainersGroup (packageName $ pkgInfoId pkg) + genDocReportList notifyPrefs (pkgid, success) = do + maintainers <- queryUserGroup $ maintainersGroup (packageName pkgid) pure . flip mapMaybe (toList maintainers) $ \uid -> fmap (uid,) $ do let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs) @@ -610,7 +612,7 @@ userNotifyFeature UserFeature{..} guard notifyDocBuilderReport Just NotifyDocsBuild - { notifyPackageId = pkgInfoId pkg + { notifyPackageId = pkgid , notifyBuildSuccess = success }