From 9d2899fcdac5d76ddeee86331fd0a43e3712e9d4 Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Wed, 21 Oct 2026 17:06:32 -0600 Subject: [PATCH] Look up only mentioned users for notifications and the legacy index The notification job looks up the recipients and the users its notifications mention, and the legacy index tarball looks up the latest uploader of each package, instead of fetching the whole user database. --- src/Distribution/Server/Features/Core.hs | 6 ++- .../Server/Features/UserNotify.hs | 47 ++++++++++++------- src/Distribution/Server/Packages/Index.hs | 8 ++-- src/Distribution/Server/Users/Users.hs | 11 +---- tests/ReverseDependenciesTest.hs | 21 +++++---- 5 files changed, 52 insertions(+), 41 deletions(-) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index b91e0450f..2dc28cd8b 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -30,6 +30,7 @@ import qualified Data.Foldable as Foldable import qualified Data.Text as Text import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Containers.ListUtils (nubOrd) import qualified Data.Vector as Vec -- hackage @@ -621,12 +622,13 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- getIndexTarball :: IO IndexTarballInfo getIndexTarball = do - users <- queryGetUserDb -- note, changes here don't automatically propagate time <- getCurrentTime Acid.PackagesState index (Right updateSeq) <- Store.getPackagesState packagesStore + -- note, changes to users here don't automatically propagate + userIdToName <- queryUserNamesFor (nubOrd (map pkgLatestUploadUser (PackageIndex.allPackages index))) let updateLog = Foldable.toList updateSeq legacyTarball = Packages.Index.writeLegacy - users + userIdToName (Packages.Index.legacyExtras updateLog) index incremTarball = Packages.Index.writeIncremental diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 24d8775fc..ad4436440 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -15,6 +15,7 @@ module Distribution.Server.Features.UserNotify ( -- * getNotificationEmails getNotificationEmails, + notificationUserIds, ) where import Distribution.Server.Features.UserDetails.Types @@ -29,9 +30,8 @@ import Distribution.Package import Distribution.Pretty import Distribution.Version -import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Group -import Distribution.Server.Users.Types (UserId, UserInfo (..)) +import Distribution.Server.Users.Types (UserId, UserInfo (..), UserName) import Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Packages.Types @@ -481,8 +481,6 @@ userNotifyFeature UserFeature{..} let trimLastTime = if diffUTCTime now lastNotifyTime > (60*60*6) -- cap at 6hr then addUTCTime (negate $ (60*60*6)) now else lastNotifyTime -- for testing you can increase this - users <- queryGetUserDb - revisionsAndUploads <- queryLatestUploadsBetween trimLastTime now revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads @@ -501,16 +499,18 @@ userNotifyFeature UserFeature{..} vouchNotifications <- fmap (, NotifyVouchingCompleted) <$> drainQueuedNotifications + let notifications = + concat + [ revisionUploadNotifications + , groupActionNotifications + , docReportNotifications + , tagProposalNotifications + , dependencyUpdateNotifications + , vouchNotifications + ] + userIdToName <- queryUserNamesFor (concatMap notificationUserIds notifications) emails <- - getNotificationEmails userFeatureServerEnv userDetailsFeature users templates $ - concat - [ revisionUploadNotifications - , groupActionNotifications - , docReportNotifications - , tagProposalNotifications - , dependencyUpdateNotifications - , vouchNotifications - ] + getNotificationEmails userFeatureServerEnv userDetailsFeature userIdToName templates notifications mapM_ sendNotifyEmailAndDelay emails Store.setNotifyTime notifyStore now @@ -649,6 +649,19 @@ userNotifyFeature UserFeature{..} -- send out too many emails threadDelay 250000 +-- | The users whose names the email for a notification shows, including its +-- recipient. +notificationUserIds :: (UserId, Notification) -> [UserId] +notificationUserIds (recipient, notif) = + recipient : case notif of + NotifyNewVersion{notifyPackageInfo} -> [pkgLatestUploadUser notifyPackageInfo] + NotifyNewRevision{notifyRevisions} -> map snd notifyRevisions + NotifyMaintainerUpdate{notifyUserActor, notifyUserSubject} -> [notifyUserActor, notifyUserSubject] + NotifyDocsBuild{} -> [] + NotifyUpdateTags{} -> [] + NotifyDependencyUpdate{} -> [] + NotifyVouchingCompleted -> [] + -- | Notifications in the same group are batched in the same email. -- -- TODO: How often do multiple notifications come in at once? Maybe it's @@ -662,14 +675,14 @@ data NotificationGroup getNotificationEmails :: ServerEnv -> UserDetailsFeature - -> Users.Users + -> (UserId -> UserName) -> Templates -> [(UserId, Notification)] -> IO [Mail] getNotificationEmails ServerEnv{serverBaseURI} UserDetailsFeature{queryUserDetails} - allUsers + userIdToName templates notifications = do let userIds = Set.fromList $ map fst notifications @@ -725,7 +738,7 @@ getNotificationEmails { uriPath = concatMap ("/" <>) [ "user" - , display $ Users.userIdToName allUsers uid + , display $ userIdToName uid , "notify" ] } @@ -850,7 +863,7 @@ getNotificationEmails { uriPath = "/package/" <> display (packageName pkg) <> "-" <> display (packageVersion pkg) } - renderUser = emailContentDisplay . Users.userIdToName allUsers + renderUser = emailContentDisplay . userIdToName renderTime = emailContentStr . formatTime defaultTimeLocale "%c" diff --git a/src/Distribution/Server/Packages/Index.hs b/src/Distribution/Server/Packages/Index.hs index 76ac2098f..497c2a678 100644 --- a/src/Distribution/Server/Packages/Index.hs +++ b/src/Distribution/Server/Packages/Index.hs @@ -22,8 +22,6 @@ import Distribution.Server.Packages.Types , pkgLatestCabalFileText, pkgLatestUploadInfo ) import Distribution.Server.Packages.Metadata -import Distribution.Server.Users.Users - ( Users, userIdToName ) import Distribution.Server.Users.Types ( UserId(..), UserName(..) ) @@ -170,8 +168,8 @@ legacyExtras = go Map.empty -- compression), contains at most one preferred-version per package (important -- because of a bug in cabal which would otherwise merge all preferred-versions -- files for a package), and does not contain the TUF files. -writeLegacy :: Users -> Map String (LazyByteString, UTCTime) -> PackageIndex PkgInfo -> LazyByteString -writeLegacy users = +writeLegacy :: (UserId -> UserName) -> Map String (LazyByteString, UTCTime) -> PackageIndex PkgInfo -> LazyByteString +writeLegacy userIdToName = writeLegacyAux (fromStrict . cabalFileByteString . pkgLatestCabalFileText) setModTime . extraEntries where @@ -187,7 +185,7 @@ writeLegacy users = } } - userName = display . userIdToName users + userName = display . userIdToName extraEntries :: Map FilePath (LazyByteString, UTCTime) -> [Tar.Entry] extraEntries emap = do diff --git a/src/Distribution/Server/Users/Users.hs b/src/Distribution/Server/Users/Users.hs index 2af5ad974..8f9abdecb 100644 --- a/src/Distribution/Server/Users/Users.hs +++ b/src/Distribution/Server/Users/Users.hs @@ -25,7 +25,6 @@ module Distribution.Server.Users.Users ( lookupAuthToken, -- ** Lookup utils - userIdToName, userIdToNameIn, userNameOrPlaceholder, @@ -169,14 +168,8 @@ lookupAuthToken authTok users = uinfo <- lookupUserId uid users return (uid, uinfo) --- | Convert a 'UserId' to a 'UserName'. If the user id doesn't exist, --- an ugly placeholder is used instead. --- -userIdToName :: Users -> UserId -> UserName -userIdToName users userId = - userNameOrPlaceholder userId (lookupUserId userId users) - --- | Like 'userIdToName', but for users that have already been looked up. +-- | Convert a 'UserId' to a 'UserName' using users that have already been +-- looked up. If the user id is missing, an ugly placeholder is used instead. -- userIdToNameIn :: Map.Map UserId UserInfo -> UserId -> UserName userIdToNameIn infos userId = diff --git a/tests/ReverseDependenciesTest.hs b/tests/ReverseDependenciesTest.hs index 88b03cf76..e4581626b 100644 --- a/tests/ReverseDependenciesTest.hs +++ b/tests/ReverseDependenciesTest.hs @@ -377,7 +377,6 @@ getNotificationEmailsTests = . getNotificationEmail testServerEnv testUserDetailsFeature - allUsers userWatcher $ NotifyDependencyUpdate { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) @@ -389,7 +388,6 @@ getNotificationEmailsTests = . getNotificationEmail testServerEnv testUserDetailsFeature - allUsers userWatcher $ NotifyDependencyUpdate { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) @@ -401,7 +399,6 @@ getNotificationEmailsTests = . getNotificationEmail testServerEnv testUserDetailsFeature - allUsers userWatcher $ NotifyDependencyUpdate { notifyPackageId = PackageIdentifier "base" (mkVersion [4, 18, 0, 0]) @@ -468,8 +465,8 @@ getNotificationEmailsTests = <*> addUser "user-actor" <*> addUser "user-subject" - getNotificationEmail env details users uid notif = - getNotificationEmails env details users (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) [(uid, notif)] >>= \case + getNotificationEmail env details uid notif = + getNotificationEmails env details (mentionedUserNames [(uid, notif)]) (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) [(uid, notif)] >>= \case [email] -> pure email _ -> error "Did not get exactly one email" @@ -490,17 +487,25 @@ getNotificationEmailsTests = , accountAdminNotes = "" } } - getNotificationEmailsMocked = + getNotificationEmailsMocked notifs = getNotificationEmails testServerEnv testUserDetailsFeature - allUsers + (mentionedUserNames notifs) (mockTemplates ["datafiles/templates/UserNotify"] ["endorsements-complete.txt"]) + notifs getNotificationEmailMocked = getNotificationEmail testServerEnv testUserDetailsFeature - allUsers + -- Resolves only the users that notificationUserIds lists, as the + -- notification job does. + mentionedUserNames notifs = + Users.userIdToNameIn . Map.fromList $ + [ (uid, uinfo) + | uid <- concatMap notificationUserIds notifs + , Just uinfo <- [Users.lookupUserId uid allUsers] + ] renderMail = fst . Mail.renderMail (mkStdGen 0) timestamp = Time.UTCTime (Time.fromGregorian 2020 1 1) 0