From 5f497709c84d237deb439f18f0659130f431c97d Mon Sep 17 00:00:00 2001 From: Janus Troelsen Date: Sun, 18 Oct 2026 14:12:36 -0600 Subject: [PATCH] Resolve user names in batches when rendering Pages, feeds and JSON resources that show user names now look up just the users they display with queryLookupUserIds, rather than fetching the whole user database. Renderers take a function from user id to name (or to user info) instead of the user database. --- .../Server/Features/AdminFrontend.hs | 6 +- src/Distribution/Server/Features/AdminLog.hs | 6 +- src/Distribution/Server/Features/Core.hs | 5 +- src/Distribution/Server/Features/Html.hs | 47 +++++++------- .../Server/Features/PackageCandidates.hs | 19 +++--- .../Server/Features/PackageContents.hs | 7 ++- .../Server/Features/PackageFeed.hs | 19 +++--- .../Server/Features/PackageList.hs | 9 ++- src/Distribution/Server/Features/Users.hs | 15 ++++- .../Server/Features/Users/Acid.hs | 3 + .../Server/Features/Users/Store.hs | 3 + src/Distribution/Server/Packages/Render.hs | 14 +++-- src/Distribution/Server/Pages/AdminLog.hs | 12 ++-- src/Distribution/Server/Pages/Recent.hs | 61 +++++++++++-------- src/Distribution/Server/Users/Users.hs | 7 +++ 15 files changed, 134 insertions(+), 99 deletions(-) diff --git a/src/Distribution/Server/Features/AdminFrontend.hs b/src/Distribution/Server/Features/AdminFrontend.hs index 47c7f4a1f..3c0e19b97 100644 --- a/src/Distribution/Server/Features/AdminFrontend.hs +++ b/src/Distribution/Server/Features/AdminFrontend.hs @@ -15,10 +15,10 @@ import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Features.UserSignup import Distribution.Server.Users.Types -import qualified Distribution.Server.Users.Users as Users import Distribution.Text import qualified Data.Text as T +import qualified Data.Map as Map import Control.Applicative (optional) import Data.Maybe (isJust) @@ -168,12 +168,12 @@ adminFrontendFeature _env templates guardAuthorised_ [InGroup adminGroup] cacheControlWithoutETag [Private] template <- getTemplate templates "resets.html" - usersdb <- queryGetUserDb allResetInfo <- queryAllSignupResetInfo + usersdb <- queryLookupUserIds [ resetUserId | ResetInfo {resetUserId} <- allResetInfo ] ok $ toResponse $ template [ "resets" $= [ resetRequestToTemplate resetInfo uinfo | resetInfo@ResetInfo {resetUserId} <- allResetInfo - , let Just uinfo = Users.lookupUserId resetUserId usersdb + , let Just uinfo = Map.lookup resetUserId usersdb ] ] diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index a14392f24..88fae5218 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -74,9 +74,9 @@ adminLogFeature UserFeature{..} Store.Backend{backendStore = adminLogStore, back queryGetAdminLog = Store.getAdminLog adminLogStore serveAdminLogGet _ = do - aLog <- queryGetAdminLog - users <- queryGetUserDb - return . toResponse . adminLogPage users . map mkRow $ aLog + rows <- map mkRow <$> queryGetAdminLog + userIdToName <- queryUserNamesFor (concatMap (\(_, actorId, _, targetId, _, _) -> [actorId, targetId]) rows) + return . toResponse . adminLogPage userIdToName $ rows mkRow (time, actorId, Admin_GroupDelUser targetId group, reason) = (time, actorId, "Acid.Delete", targetId, nameIt group, unpackUTF8 reason) diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index b7fb3f9c3..b91e0450f 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -50,7 +50,6 @@ import qualified Distribution.Server.Packages.PackageIndex as PackageIn import Distribution.Server.Packages.Types import Distribution.Server.Users.Types (UserId, userName) -import Distribution.Server.Users.Users (userIdToName) -- Cabal import Distribution.Package @@ -747,9 +746,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} serveCabalFileRevisionsList :: DynamicPath -> ServerPartE Response serveCabalFileRevisionsList dpath = do revisions <- fmap pkgMetadataRevisions $ packageInPath dpath >>= lookupPackageId - users <- queryGetUserDb + userIdToName <- queryUserNamesFor (map (snd . snd) (Vec.toList revisions)) let revisionToObj rev (cabalFileText, (utime, uid)) = - let uname = userIdToName users uid + let uname = userIdToName uid hash = sha256 (fromStrict $ cabalFileByteString cabalFileText) in Object $ KeyMap.fromList diff --git a/src/Distribution/Server/Features/Html.hs b/src/Distribution/Server/Features/Html.hs index f3e485111..5f9490e61 100644 --- a/src/Distribution/Server/Features/Html.hs +++ b/src/Distribution/Server/Features/Html.hs @@ -43,7 +43,6 @@ import Distribution.Server.Users.Types import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Packages.Types import Distribution.Server.Packages.Render -import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Group (UserGroup(..)) import qualified Distribution.Server.Pages.Package as Pages @@ -433,7 +432,7 @@ mkHtmlCore :: ServerEnv -> HtmlCore mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} utilities@HtmlUtilities{..} - UserFeature{queryGetUserDb, checkAuthenticated, guardAuthorised_, adminGroup} + UserFeature{queryUserNamesFor, checkAuthenticated, guardAuthorised_, adminGroup} CoreFeature{coreResource} VersionsFeature{ versionsResource , queryGetDeprecatedFor @@ -544,48 +543,48 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} serveRecentPage :: DynamicPath -> ServerPartE Response serveRecentPage _ = do recentPackages <- getRecentPackages - users <- queryGetUserDb page <- lookupPage 1 pageSize <- lookupPageSize 20 let conf = Paging.createConf page pageSize recentPackages + userIdToName <- queryUserNamesFor (Pages.recentUserIds conf recentPackages) - return . toResponse $ Pages.recentPage conf users recentPackages + return . toResponse $ Pages.recentPage conf userIdToName recentPackages serveRecentRSS :: DynamicPath -> ServerPartE Response serveRecentRSS _ = do recentPackages <- getRecentPackages - users <- queryGetUserDb page <- lookupPage 1 pageSize <- lookupPageSize 20 now <- liftIO getCurrentTime let conf = Paging.createConf page pageSize recentPackages + userIdToName <- queryUserNamesFor (Pages.recentUserIds conf recentPackages) - return . toResponse $ Pages.recentFeed conf users serverBaseURI now recentPackages + return . toResponse $ Pages.recentFeed conf userIdToName serverBaseURI now recentPackages serveRevisionPage :: DynamicPath -> ServerPartE Response serveRevisionPage _ = do revisions <- getRecentRevisions - users <- queryGetUserDb page <- lookupPage 1 pageSize <- lookupPageSize 40 let conf = Paging.createConf page pageSize revisions + userIdToName <- queryUserNamesFor (Pages.revisionsUserIds conf revisions) - return . toResponse $ Pages.revisionsPage conf users revisions + return . toResponse $ Pages.revisionsPage conf userIdToName revisions serveRevisionRSS :: DynamicPath -> ServerPartE Response serveRevisionRSS _ = do revisions <- getRecentRevisions - users <- queryGetUserDb page <- lookupPage 1 pageSize <- lookupPageSize 40 now <- liftIO getCurrentTime let conf = Paging.createConf page pageSize revisions + userIdToName <- queryUserNamesFor (Pages.revisionsUserIds conf revisions) - return . toResponse $ Pages.recentRevisionsFeed conf users serverBaseURI now revisions + return . toResponse $ Pages.recentRevisionsFeed conf userIdToName serverBaseURI now revisions serveBrowsePage :: DynamicPath -> ServerPartE Response serveBrowsePage _dpath = do @@ -665,8 +664,8 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} mdocIndex <- maybe (return Nothing) (liftM Just . liftIO . cachedTarIndex) mdoctarblob analyticsPixels <- getPackageAnalyticsPixels pkgname - userDb <- queryGetUserDb maintainerlist <- liftIO $ queryUserGroup maintainers + maintainerName <- queryUserNamesFor (Group.toList maintainerlist) let idAndReport = fmap (\(rptId, rpt, _, _) -> (rptId, rpt)) rptStats install = getInstall $ fmap (fst &&& BR.installOutcome . snd) idAndReport @@ -720,7 +719,7 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} , "candidates" $= case candidates of [] -> [ toHtml "No Candidates"] _ -> [ PagesNew.commaList $ flip map candidates $ \cand -> anchor ! [href $ corePackageIdUri candidatesCore "" $ packageId cand] << display (packageVersion cand) ] - , "maintainers" $= listGroupCompact (map (Users.userIdToName userDb) (Group.toList maintainerlist)) + , "maintainers" $= listGroupCompact (map maintainerName (Group.toList maintainerlist)) ] ++ -- Items not related to IO (mostly pure functions) PagesNew.packagePageTemplate render @@ -800,7 +799,6 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} serveCabalRevisionsPage :: DynamicPath -> ServerPartE Response serveCabalRevisionsPage dpath = do pkginfo <- packageInPath dpath >>= lookupPackageId - users <- queryGetUserDb let pkgid = packageId pkginfo pkgname = packageName pkginfo cabalFiles = reverse $ pkgAllRevisionsCabalFiles pkginfo @@ -823,22 +821,23 @@ mkHtmlCore ServerEnv{serverBaseURI, serverBlobStore} (cabalFileByteString prev) (cabalFileByteString curr) + userIdToName <- queryUserNamesFor (map snd uploadInfos) cacheControl [NoCache] (etagFromHash numRevisions) template <- getTemplate templates "revisions.html" return $ toResponse $ template [ "pkgname" $= pkgname , "pkgid" $= pkgid - , "revisions" $= zipWith3 (revisionToTemplate users) + , "revisions" $= zipWith3 (revisionToTemplate userIdToName) uploadInfos [numRevisions-1, numRevisions-2..] revchanges ] where - revisionToTemplate :: Users.Users -> UploadInfo -> Int + revisionToTemplate :: (UserId -> UserName) -> UploadInfo -> Int -> (SHA256Digest, [Change]) -> TemplateVal - revisionToTemplate users (utime, uid) revision (sha256hash, changes) = - let uname = Users.userIdToName users uid + revisionToTemplate userIdToName (utime, uid) revision (sha256hash, changes) = + let uname = userIdToName uid in templateDict [ templateVal "number" revision , templateVal "sha256" (show sha256hash) @@ -1184,7 +1183,7 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..} DocumentationFeature{documentationResource, queryDocumentation,..} TarIndexCacheFeature{cachedTarIndex} PackageCandidatesFeature{..} - UserFeature{ guardAuthorised, guardAuthorised_, queryGetUserDb } + UserFeature{ guardAuthorised, guardAuthorised_, queryUserNamesFor } templates = HtmlCandidates{..} where candidates = candidatesResource @@ -1352,14 +1351,14 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..} warn -> [thediv ! [theclass "candidate-warn"] << [paragraph << strong (toHtml "Warnings:"), unordList warn]] let maintainers = maintainersGroup pkgname - userDb <- queryGetUserDb maintainerlist <- liftIO $ queryUserGroup maintainers + maintainerName <- queryUserNamesFor (Group.toList maintainerlist) return $ toResponse . template $ [ "versions" $= (PagesNew.renderVersion (packageId cand) (classifyVersions prefInfo $ insert version otherVersions) Nothing) , "maintainHtml" $= [maintainHtml] , "warningBox" $= warningBox - , "maintainers" $= listGroupCompact (map (Users.userIdToName userDb) (Group.toList maintainerlist)) + , "maintainers" $= listGroupCompact (map maintainerName (Group.toList maintainerlist)) ] ++ PagesNew.packagePageTemplate render mdocIndex mdocMeta mreadme @@ -2065,9 +2064,9 @@ htmlGroupResource UserFeature{..} r@(GroupResource groupR userR getGroup) = where getList dpath = do group <- getGroup dpath - userDb <- queryGetUserDb usergroup <- liftIO . queryUserGroup $ group - let unames = [ Users.userIdToName userDb uid + userIdToName <- queryUserNamesFor (Group.toList usergroup) + let unames = [ userIdToName uid | uid <- Group.toList usergroup ] let baseUri = renderResource' groupR dpath cacheControl [NoCache] (etagFromHash unames) @@ -2076,9 +2075,9 @@ htmlGroupResource UserFeature{..} r@(GroupResource groupR userR getGroup) = getEditList dpath = do group <- getGroup dpath (canAdd, canDelete) <- lookupGroupEditAuth group - userDb <- queryGetUserDb usergroup <- liftIO . queryUserGroup $ group - let unames = [ Users.userIdToName userDb uid + userIdToName <- queryUserNamesFor (Group.toList usergroup) + let unames = [ userIdToName uid | uid <- Group.toList usergroup ] let baseUri = renderResource' groupR dpath cacheControl [NoCache] (etagFromHash unames) diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index fb4329977..368a46bf4 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -24,7 +24,6 @@ import Distribution.Server.Packages.Render import Distribution.Server.Packages.ChangeLog import Distribution.Server.Packages.Readme import qualified Distribution.Server.Users.Types as Users -import qualified Distribution.Server.Users.Users as Users import qualified Distribution.Server.Users.Group as Group import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import qualified Distribution.Server.Packages.PackageIndex as PackageIndex @@ -52,6 +51,7 @@ import Data.Function (fix) import Data.List (find, intersperse) import Data.Time.Clock (getCurrentTime) import qualified Data.Vector as Vec +import qualified Data.Map as Map data PackageCandidatesFeature = PackageCandidatesFeature { @@ -269,16 +269,19 @@ candidatesFeature ServerEnv{serverBlobStore = store} pkgname <- packageInPath dpath pkgs <- lookupCandidateName pkgname - users <- queryGetUserDb - let lupUserName uid = (uid, fmap Users.userName (Users.lookupUserId uid users)) + let latestTarballs = [ (p, tarball, time, uploader) + | p <- pkgs + , (tarball, (time, uploader), _) <- maybeToList $ pkgLatestTarball $ candPkgInfo p + ] + users <- queryLookupUserIds [ uploader | (_, _, _, uploader) <- latestTarballs ] + let lupUserName uid = (uid, fmap Users.userName (Map.lookup uid users)) let pvs = [ object [ Key.fromString "version" .= (T.pack . display . packageVersion . candInfoId) p , Key.fromString "sha256" .= (blobInfoHashSHA256 . pkgTarballGz) tarball , Key.fromString "time" .= time , Key.fromString "uploader" .= lupUserName uploader ] - | p <- pkgs - , (tarball, (time, uploader), _) <- maybeToList $ pkgLatestTarball $ candPkgInfo p + | (p, tarball, time, uploader) <- latestTarballs ] return . toResponse . toJSON $ pvs @@ -516,14 +519,14 @@ candidatesFeature ServerEnv{serverBlobStore = store} candidateRender :: CandPkgInfo -> IO CandidateRender candidateRender cand = do - users <- queryGetUserDb - indexedPkgs <- queryLookupPackageName (packageName cand) let pkg = candPkgInfo cand + users <- queryLookupUserIds (packageRenderUserIds pkg) + indexedPkgs <- queryLookupPackageName (packageName cand) changeLog <- findToplevelFile pkg isChangeLogFile >>= either (\_ -> return Nothing) (return . Just) readme <- findToplevelFile pkg isReadmeFile >>= either (\_ -> return Nothing) (return . Just) - let render = doPackageRender users pkg + let render = doPackageRender (`Map.lookup` users) pkg return $ CandidateRender { candPackageRender = render { rendPkgUri = rendPkgUri render ++ "/candidate" , rendChangeLog = changeLog diff --git a/src/Distribution/Server/Features/PackageContents.hs b/src/Distribution/Server/Features/PackageContents.hs index 03dddbd17..6273a5163 100644 --- a/src/Distribution/Server/Features/PackageContents.hs +++ b/src/Distribution/Server/Features/PackageContents.hs @@ -27,6 +27,7 @@ import Distribution.PackageDescription import qualified Text.XHtml.Strict as XHtml import qualified Distribution.Utils.ShortText as ST +import qualified Data.Map as Map import Text.XHtml.Strict ((<<), (!)) @@ -71,7 +72,7 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{ } } TarIndexCacheFeature{packageTarball, findToplevelFile} - UserFeature{queryGetUserDb, userFeatureServerEnv} + UserFeature{queryLookupUserIds, userFeatureServerEnv} = PackageContentsFeature{..} where packageFeatureInterface = (emptyHackageFeature "package-contents") { @@ -103,12 +104,12 @@ packageContentsFeature CoreFeature{ coreResource = CoreResource{ packageRender :: PkgInfo -> IO PackageRender packageRender pkg = do - users <- queryGetUserDb + users <- queryLookupUserIds (packageRenderUserIds pkg) changeLog <- findToplevelFile pkg isChangeLogFile >>= either (\_ -> return Nothing) (return . Just) readme <- findToplevelFile pkg isReadmeFile >>= either (\_ -> return Nothing) (return . Just) - let render = doPackageRender users pkg + let render = doPackageRender (`Map.lookup` users) pkg return $ render { rendChangeLog = changeLog, rendReadme = readme } {------------------------------------------------------------------------------- diff --git a/src/Distribution/Server/Features/PackageFeed.hs b/src/Distribution/Server/Features/PackageFeed.hs index d99432629..e2702b324 100644 --- a/src/Distribution/Server/Features/PackageFeed.hs +++ b/src/Distribution/Server/Features/PackageFeed.hs @@ -8,8 +8,7 @@ import Distribution.Server.Features.Users import Distribution.Server.Framework import Distribution.Server.Packages.ChangeLog import Distribution.Server.Packages.Types -import qualified Distribution.Server.Users.Users as Users -import Distribution.Server.Users.Users (Users) +import Distribution.Server.Users.Types (UserId, UserName) import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.Server.Util.ServeTarball (loadTarEntry) import Distribution.Server.Util.Markdown (renderMarkdown, supposedToBeMarkdown) @@ -77,12 +76,12 @@ packageFeedFeature ServerEnv{..} packageFeed :: DynamicPath -> ServerPartE Response packageFeed dpath = do - users <- queryGetUserDb now <- liftIO getCurrentTime pkgname <- packageInPath dpath pkgs <- sortOn (Down . pkgOriginalUploadTime) <$> lookupPackageName pkgname + userIdToName <- queryUserNamesFor (map (snd . pkgOriginalUploadInfo) pkgs) pkgs' <- liftIO $ forM pkgs changelog - return $ toResponse $ renderPackageFeed users serverBaseURI now pkgname pkgs' + return $ toResponse $ renderPackageFeed userIdToName serverBaseURI now pkgname pkgs' changelog :: PkgInfo -> IO (PkgInfo, XHtml.Html) changelog pkg = findToplevelFile pkg isChangeLogFile >>= \case @@ -95,11 +94,11 @@ packageFeedFeature ServerEnv{..} then return (pkg, renderMarkdown filename content) else return (pkg, XHtml.pre << unpackUTF8 content) -renderPackageFeed :: Users -> URI -> UTCTime -> PackageName -> [(PkgInfo, XHtml.Html)] -> RSS -renderPackageFeed users hostURI now name pkgs = RSS title uri desc (channel updated) items +renderPackageFeed :: (UserId -> UserName) -> URI -> UTCTime -> PackageName -> [(PkgInfo, XHtml.Html)] -> RSS +renderPackageFeed userIdToName hostURI now name pkgs = RSS title uri desc (channel updated) items where title = unPackageName name ++ " – new releases on Hackage" desc = "New releases of package '" ++ unPackageName name ++ "' on Hackage." - items = feedItems users uri <$> pkgs + items = feedItems userIdToName uri <$> pkgs uri = hostURI { uriPath = "/package/" ++ display name } updated = maybe now (fst . pkgOriginalUploadInfo . fst) (listToMaybe pkgs) @@ -113,8 +112,8 @@ channel updated = , RSS.Generator "rss-feed" ] -feedItems :: Users -> URI -> (PkgInfo, XHtml.Html) -> [RSS.ItemElem] -feedItems users hostURI (pkgInfo, chlog) = +feedItems :: (UserId -> UserName) -> URI -> (PkgInfo, XHtml.Html) -> [RSS.ItemElem] +feedItems userIdToName hostURI (pkgInfo, chlog) = [ RSS.Title title , RSS.Link uri , RSS.Guid True (uriToString id uri "") @@ -133,6 +132,6 @@ feedItems users hostURI (pkgInfo, chlog) = pkgName = display (pkgInfoId pkgInfo) (time, uploaderId) = pkgOriginalUploadInfo pkgInfo timestr = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" time - uploader = display $ Users.userIdToName users uploaderId + uploader = display $ userIdToName uploaderId pd = packageDescription (pkgDesc pkgInfo) d dt dd = XHtml.dterm (XHtml.toHtml dt) +++ XHtml.ddef (XHtml.toHtml dd) diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index 5f03931cd..da1d64ea3 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -15,7 +15,6 @@ import Distribution.Server.Features.DownloadCount import Distribution.Server.Features.Tags import Distribution.Server.Features.Users import Distribution.Server.Features.Upload(UploadFeature(..)) -import Distribution.Server.Users.Users (userIdToName) import qualified Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Users.Group(UserGroup(..), GroupDescription(..)) import Distribution.Server.Features.PreferredVersions @@ -164,8 +163,8 @@ initListFeature _env = do case fmap (mkPackageName . fst) (groupEntity gd) of Just pkgname -> do maintainers <- queryUserGroup (maintainersGroup pkgname) - users' <- queryGetUserDb - modifyItem pkgname (\x -> x {itemMaintainer = map (userIdToName users') (UserIdSet.toList maintainers)}) + userIdToName <- queryUserNamesFor (UserIdSet.toList maintainers) + modifyItem pkgname (\x -> x {itemMaintainer = map userIdToName (UserIdSet.toList maintainers)}) runHook_ itemUpdate (Set.singleton pkgname) Nothing -> return () @@ -282,17 +281,17 @@ listFeature CoreFeature{..} let pkgname = packageName pkg desc = pkgDesc pkg intRevDirectCount <- revDirectCount pkgname - users <- queryGetUserDb tags <- queryTagsForPackage pkgname downs <- recentPackageDownloads votes <- pkgNumScore pkgname deprs <- queryGetDeprecatedFor pkgname maintainers <- queryUserGroup (maintainersGroup pkgname) + userIdToName <- queryUserNamesFor (UserIdSet.toList maintainers) prefsinfo <- queryGetPreferredInfo pkgname return $ (,) pkgname . updateReferenceVersion prefsinfo [pkgVersion (pkgInfoId pkg)] $ (updateDescriptionItem desc $ emptyPackageItem pkgname) { itemTags = tags - , itemMaintainer = map (userIdToName users) (UserIdSet.toList maintainers) + , itemMaintainer = map userIdToName (UserIdSet.toList maintainers) , itemDeprecated = deprs , itemDownloads = cmFind pkgname downs , itemVotes = votes diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index 04482cb7a..c7ecc07c3 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -75,6 +75,11 @@ data UserFeature = UserFeature { queryGetUserDb :: forall m. MonadIO m => m Acid.Users, queryLookupUserId :: forall m. MonadIO m => UserId -> m (Maybe UserInfo), queryLookupUserName :: forall m. MonadIO m => UserName -> m (Maybe (UserId, UserInfo)), + -- | Retrieves the given user accounts, leaving out ids that do not exist. + queryLookupUserIds :: forall m. MonadIO m => [UserId] -> m (Map UserId UserInfo), + -- | Retrieves the given user accounts, as a function from user id to user + -- name. Ids that were not given or do not exist get a placeholder name. + queryUserNamesFor :: forall m. MonadIO m => [UserId] -> m (UserId -> UserName), -- | Retrieves every user account, including disabled and deleted ones. queryAllUsers :: forall m. MonadIO m => m [(UserId, UserInfo)], -- | Retrieves every user account except deleted ones. @@ -381,6 +386,12 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = queryLookupUserName :: MonadIO m => UserName -> m (Maybe (UserId, UserInfo)) queryLookupUserName = UserStore.lookupUserName userStore + queryLookupUserIds :: MonadIO m => [UserId] -> m (Map UserId UserInfo) + queryLookupUserIds = UserStore.lookupUserIds userStore + + queryUserNamesFor :: MonadIO m => [UserId] -> m (UserId -> UserName) + queryUserNamesFor uids = Acid.userIdToNameIn <$> queryLookupUserIds uids + queryAllUsers :: MonadIO m => m [(UserId, UserInfo)] queryAllUsers = UserStore.enumerateAllUsers userStore @@ -870,14 +881,14 @@ userFeature templates UserStore.Backend{backendStore = userStore, backendState = serveUserGroupGet groupr dpath = do group <- getGroup groupr dpath - userDb <- queryGetUserDb userlist <- liftIO $ queryUserGroup group + userIdToName <- queryUserNamesFor (Group.toList userlist) return . toResponse $ toJSON UserGroupResource { ui_title = T.pack $ groupTitle (groupDesc group), ui_description = T.pack $ groupPrologue (groupDesc group), ui_members = [ UserNameIdResource { - ui_username = Acid.userIdToName userDb uid, + ui_username = userIdToName uid, ui_userid = uid } | uid <- Group.toList userlist ] diff --git a/src/Distribution/Server/Features/Users/Acid.hs b/src/Distribution/Server/Features/Users/Acid.hs index 28bb94715..a6dabd059 100644 --- a/src/Distribution/Server/Features/Users/Acid.hs +++ b/src/Distribution/Server/Features/Users/Acid.hs @@ -15,6 +15,7 @@ import Distribution.Server.Users.Types (UserInfo(userName), UserName(UserName)) import Distribution.Simple.Utils (lowercase) import Data.List (isInfixOf) +import qualified Data.Map as Map acidStore :: FilePath -> IO Store.Backend acidStore stateDir = do @@ -27,6 +28,8 @@ acidStore stateDir = do Store.getUsers = queryState usersState Acid.GetUserDb , Store.lookupUserId = \uid -> withUsers (Acid.lookupUserId uid) , Store.lookupUserName = \uname -> withUsers (Acid.lookupUserName uname) + , Store.lookupUserIds = \uids -> withUsers $ \users -> + Map.fromList [ (uid, uinfo) | uid <- uids, Just uinfo <- [Acid.lookupUserId uid users] ] , Store.lookupAuthToken = \token -> withUsers (Acid.lookupAuthToken token) , Store.enumerateAllUsers = withUsers Acid.enumerateAllUsers , Store.enumerateActiveUsers = withUsers Acid.enumerateActiveUsers diff --git a/src/Distribution/Server/Features/Users/Store.hs b/src/Distribution/Server/Features/Users/Store.hs index 6ece557d6..b0a2fb79a 100644 --- a/src/Distribution/Server/Features/Users/Store.hs +++ b/src/Distribution/Server/Features/Users/Store.hs @@ -17,6 +17,7 @@ import Distribution.Server.Users.Users ) import Control.Monad.Trans (MonadIO) +import Data.Map (Map) import Data.Text (Text) data Backend = Backend { @@ -28,6 +29,8 @@ data Store = Store { getUsers :: forall m. MonadIO m => m Users , lookupUserId :: forall m. MonadIO m => UserId -> m (Maybe UserInfo) , lookupUserName :: forall m. MonadIO m => UserName -> m (Maybe (UserId, UserInfo)) + -- | The given users that exist. + , lookupUserIds :: forall m. MonadIO m => [UserId] -> m (Map UserId UserInfo) , lookupAuthToken :: forall m. MonadIO m => AuthToken -> m (Maybe (UserId, UserInfo)) , enumerateAllUsers :: forall m. MonadIO m => m [(UserId, UserInfo)] -- | Every user account except deleted ones. diff --git a/src/Distribution/Server/Packages/Render.hs b/src/Distribution/Server/Packages/Render.hs index 83eed1675..eb5afcc55 100644 --- a/src/Distribution/Server/Packages/Render.hs +++ b/src/Distribution/Server/Packages/Render.hs @@ -8,6 +8,7 @@ module Distribution.Server.Packages.Render ( , DependencyTree , IsBuildable (..) , doPackageRender + , packageRenderUserIds , ModSigIndex(..) -- * Utils @@ -48,7 +49,6 @@ import Distribution.Types.LibraryVisibility (LibraryVisibility(LibraryVisibility import Distribution.Server.Framework.CacheControl (ETag) import Distribution.Server.Packages.Types import Distribution.Server.Packages.ModuleForest -import qualified Distribution.Server.Users.Users as Users import Distribution.Server.Users.Types import Distribution.Utils.Path (getSymbolicPath) import Distribution.Utils.ShortText (fromShortText) @@ -97,8 +97,12 @@ data PackageRender = PackageRender { rendOther :: PackageDescription } -doPackageRender :: Users.Users -> PkgInfo -> PackageRender -doPackageRender users info = PackageRender +-- | The users whose info 'doPackageRender' shows. +packageRenderUserIds :: PkgInfo -> [UserId] +packageRenderUserIds info = [snd (pkgOriginalUploadInfo info), snd (pkgLatestUploadInfo info)] + +doPackageRender :: (UserId -> Maybe UserInfo) -> PkgInfo -> PackageRender +doPackageRender lookupUser info = PackageRender { rendPkgId = packageId' , rendDepends = flatDependencies genDesc , rendLibName = renderLibName @@ -123,10 +127,10 @@ doPackageRender users info = PackageRender , rendChangeLog = Nothing -- populated later , rendReadme = Nothing -- populated later , rendUploadInfo = let (utime, uid) = pkgOriginalUploadInfo info - in (utime, Users.lookupUserId uid users) + in (utime, lookupUser uid) , rendUpdateInfo = let maxrevision = pkgMaxRevision info (utime, uid) = pkgLatestUploadInfo info - uinfo = Users.lookupUserId uid users + uinfo = lookupUser uid in if maxrevision > MetadataRevIx 0 then Just (maxrevision, utime, uinfo) else Nothing diff --git a/src/Distribution/Server/Pages/AdminLog.hs b/src/Distribution/Server/Pages/AdminLog.hs index c4a516c12..83c628c26 100644 --- a/src/Distribution/Server/Pages/AdminLog.hs +++ b/src/Distribution/Server/Pages/AdminLog.hs @@ -4,9 +4,7 @@ module Distribution.Server.Pages.AdminLog ( adminLogPage ) where -import qualified Distribution.Server.Users.Users as Users -import Distribution.Server.Users.Users (Users) -import Distribution.Server.Users.Types (UserId) +import Distribution.Server.Users.Types (UserId, UserName) import Distribution.Server.Pages.Template ( hackagePage) @@ -21,16 +19,16 @@ import Data.Time.Clock import Data.Time.Format ( defaultTimeLocale, formatTime ) -adminLogPage :: Users -> [(UTCTime, UserId, String, UserId, String, String)] -> Html -adminLogPage users entries = hackagePage "adminstrator actions log" docBody +adminLogPage :: (UserId -> UserName) -> [(UTCTime, UserId, String, UserId, String, String)] -> Html +adminLogPage userIdToName entries = hackagePage "adminstrator actions log" docBody where docBody = [XHtml.h2 << "Administrator actions", XHtml.table ! [XHtml.align "center"] << (header : map makeRow entries)] makeRow (time, actorId, action, targetId, group, reason) = XHtml.tr << map fmtCell [showTime time, - display $ Users.userIdToName users actorId, + display $ userIdToName actorId, action, - display $ Users.userIdToName users targetId, + display $ userIdToName targetId, group, reason] nbsp = XHtml.primHtmlChar "nbsp" diff --git a/src/Distribution/Server/Pages/Recent.hs b/src/Distribution/Server/Pages/Recent.hs index ac60f89af..41ae45a59 100644 --- a/src/Distribution/Server/Pages/Recent.hs +++ b/src/Distribution/Server/Pages/Recent.hs @@ -4,13 +4,14 @@ module Distribution.Server.Pages.Recent ( recentPage, recentFeed, + recentUserIds, revisionsPage, recentRevisionsFeed, + revisionsUserIds, ) where import Distribution.Server.Packages.Types -import qualified Distribution.Server.Users.Users as Users -import Distribution.Server.Users.Users (Users) +import Distribution.Server.Users.Types (UserId, UserName) import Distribution.Server.Pages.Template ( hackagePageWithHead ) @@ -34,11 +35,19 @@ import Data.Maybe ( listToMaybe, fromMaybe) import Distribution.Server.Util.Paging (PaginatedConfiguration(..), hasNext, hasPrev, nextURL, pageIndexRange, paginate, prevURL, toURL, allPagedURLs, pagingInfo) +-- | The users that 'recentPage' and 'recentFeed' show. +recentUserIds :: PaginatedConfiguration -> [PkgInfo] -> [UserId] +recentUserIds conf = map (snd . pkgOriginalUploadInfo) . paginate conf + +-- | The users that 'revisionsPage' and 'recentRevisionsFeed' show. +revisionsUserIds :: PaginatedConfiguration -> [PkgInfo] -> [UserId] +revisionsUserIds conf = map (snd . pkgLatestUploadInfo) . paginate conf + -- | Takes a list of package info, in reverse order by timestamp. -recentPage :: PaginatedConfiguration -> Users -> [PkgInfo] -> Html -recentPage conf users pkgs = - let log_rows = makeRow users <$> paginate conf pkgs +recentPage :: PaginatedConfiguration -> (UserId -> UserName) -> [PkgInfo] -> Html +recentPage conf userIdToName pkgs = + let log_rows = makeRow userIdToName <$> paginate conf pkgs docBody = [ XHtml.h2 << "Recent additions", pageSizeForm recentURL, @@ -110,9 +119,9 @@ insertAt n a x = case splitAt n x of (hts, hts') -> hts ++ [a] ++ hts' takeLast :: Int -> [a] -> [a] takeLast n = reverse . take n . reverse -revisionsPage :: PaginatedConfiguration -> Users -> [PkgInfo] -> Html -revisionsPage conf users pkgs = - let log_rows = map (makeRevisionRow users) (paginate conf pkgs) +revisionsPage :: PaginatedConfiguration -> (UserId -> UserName) -> [PkgInfo] -> Html +revisionsPage conf userIdToName pkgs = + let log_rows = map (makeRevisionRow userIdToName) (paginate conf pkgs) docBody = [ XHtml.h2 << "Recent cabal metadata revisions", pageSizeForm recentRevisionsURL, @@ -129,8 +138,8 @@ revisionsPage conf users pkgs = << XHtml.noHtml in hackagePageWithHead [rss_link] "recent revisions" docBody -makeRow :: Users -> PkgInfo -> Html -makeRow users pkginfo = +makeRow :: (UserId -> UserName) -> PkgInfo -> Html +makeRow userIdToName pkginfo = XHtml.tr << [XHtml.td ! [XHtml.align "right"] << [showTimeHtml time, nbsp, nbsp], @@ -140,13 +149,13 @@ makeRow users pkginfo = [XHtml.href (packageURL pkgid)] << display pkgid]] where nbsp = XHtml.primHtmlChar "nbsp" - user = Users.userIdToName users userId + user = userIdToName userId (time, userId) = pkgOriginalUploadInfo pkginfo pkgid = pkgInfoId pkginfo -makeRevisionRow :: Users -> PkgInfo -> Html -makeRevisionRow users pkginfo = +makeRevisionRow :: (UserId -> UserName) -> PkgInfo -> Html +makeRevisionRow userIdToName pkginfo = XHtml.tr << [XHtml.td ! [XHtml.align "right"] << [showTimeHtml time, nbsp, nbsp], @@ -156,7 +165,7 @@ makeRevisionRow users pkginfo = [XHtml.href (packageURL pkgid ++ "/revisions")] << revlabel]] where nbsp = XHtml.primHtmlChar "nbsp" - user = Users.userIdToName users userId + user = userIdToName userId (time, userId) = pkgLatestUploadInfo pkginfo pkgid = pkgInfoId pkginfo @@ -190,26 +199,26 @@ recentRevisionsURL :: URL recentRevisionsURL = "/packages/recent/revisions.html" -recentFeed :: PaginatedConfiguration -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS -recentFeed conf users hostURI now pkgs = RSS +recentFeed :: PaginatedConfiguration -> (UserId -> UserName) -> URI -> UTCTime -> [PkgInfo] -> RSS +recentFeed conf userIdToName hostURI now pkgs = RSS "Recent additions" (hostURI { uriPath = recentAdditionsURL}) desc (channel updated) - (map (releaseItem users hostURI) pkgList) + (map (releaseItem userIdToName hostURI) pkgList) where (start,end) = pageIndexRange conf desc = "Showing " ++ show start ++ " - " ++ show end ++ " most recent additions to Hackage, the Haskell package database." pkgList = paginate conf pkgs updated = maybe now (fst . pkgOriginalUploadInfo) (listToMaybe pkgList) -recentRevisionsFeed :: PaginatedConfiguration -> Users -> URI -> UTCTime -> [PkgInfo] -> RSS -recentRevisionsFeed conf users hostURI now pkgs = RSS +recentRevisionsFeed :: PaginatedConfiguration -> (UserId -> UserName) -> URI -> UTCTime -> [PkgInfo] -> RSS +recentRevisionsFeed conf userIdToName hostURI now pkgs = RSS "Recent revisions" (hostURI { uriPath = recentRevisionsURL}) desc (channel updated) - (map (revisionItem users hostURI) pkgList) + (map (revisionItem userIdToName hostURI) pkgList) where (start, end) = pageIndexRange conf desc = "Showing " ++ show start ++ " - " ++ show end ++ " most recent revisions to cabal metadata in Hackage, the Haskell package database." @@ -228,8 +237,8 @@ channel updated = where email = "admin@hackage.haskell.org" --TODO: make this configurable -releaseItem :: Users -> URI -> PkgInfo -> [RSS.ItemElem] -releaseItem users hostURI pkgInfo = +releaseItem :: (UserId -> UserName) -> URI -> PkgInfo -> [RSS.ItemElem] +releaseItem userIdToName hostURI pkgInfo = [ RSS.Title title , RSS.Link uri , RSS.Guid True (uriToString id uri "") @@ -242,13 +251,13 @@ releaseItem users hostURI pkgInfo = body = fromShortText $ synopsis (packageDescription (pkgDesc pkgInfo)) desc = "Added by " ++ display user ++ ", " ++ showTime time ++ "." ++ if null body then "" else "

" ++ body ++ "

" - user = Users.userIdToName users userId + user = userIdToName userId (time, userId) = pkgOriginalUploadInfo pkgInfo pkgId = pkgInfoId pkgInfo -revisionItem :: Users -> URI -> PkgInfo -> [RSS.ItemElem] -revisionItem users hostURI pkgInfo = +revisionItem :: (UserId -> UserName) -> URI -> PkgInfo -> [RSS.ItemElem] +revisionItem userIdToName hostURI pkgInfo = [ RSS.Title title , RSS.Link uri , RSS.Guid True (uriToString id guid "") @@ -262,7 +271,7 @@ revisionItem users hostURI pkgInfo = body = "Revision #" ++ show revision desc = "Revised by " ++ display user ++ ", " ++ showTime time ++ "." ++ if null body then "" else "

" ++ body ++ "

" - user = Users.userIdToName users userId + user = userIdToName userId revision = pkgNumRevisions pkgInfo - 1 (time, userId) = pkgLatestUploadInfo pkgInfo diff --git a/src/Distribution/Server/Users/Users.hs b/src/Distribution/Server/Users/Users.hs index 94a42aa74..2af5ad974 100644 --- a/src/Distribution/Server/Users/Users.hs +++ b/src/Distribution/Server/Users/Users.hs @@ -26,6 +26,7 @@ module Distribution.Server.Users.Users ( -- ** Lookup utils userIdToName, + userIdToNameIn, userNameOrPlaceholder, -- * Enumeration @@ -175,6 +176,12 @@ userIdToName :: Users -> UserId -> UserName userIdToName users userId = userNameOrPlaceholder userId (lookupUserId userId users) +-- | Like 'userIdToName', but for users that have already been looked up. +-- +userIdToNameIn :: Map.Map UserId UserInfo -> UserId -> UserName +userIdToNameIn infos userId = + userNameOrPlaceholder userId (Map.lookup userId infos) + -- | The name of a looked-up user. If there is no such user, an ugly -- placeholder is used instead. --