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