Resolve user names in batches when rendering

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
                         ]
           ]
 

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)

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

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)

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

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 }
 
 {-------------------------------------------------------------------------------

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)