Narrower package/user queries

src/Distribution/Server/Features.hs

@@ -15,7 +15,7 @@ import Distribution.Server.Framework.Logging
 
 import Distribution.Server.Features.StaticFiles (initStaticFilesFeature)
 import Distribution.Server.Features.Users    (initUserFeature, UserFeature)
-import Distribution.Server.Features.Core     (initCoreFeature, coreResource, queryGetPackageIndex)
+import Distribution.Server.Features.Core     (initCoreFeature, coreResource, queryAllPackageIds)
 import Distribution.Server.Features.Security (initSecurityFeature)
 import Distribution.Server.Features.Upload   (initUploadFeature)
 import Distribution.Server.Features.Mirror   (initMirrorFeature)
@@ -243,7 +243,7 @@ initHackageFeatures env@ServerEnv{serverVerbosity = verbosity} = do
 
     documentationCoreFeature <- mkDocumentationCoreFeature
                          (coreResource coreFeature)
-                         (map packageId . allPackages <$> queryGetPackageIndex coreFeature)
+                         (queryAllPackageIds coreFeature)
                          uploadFeature
                          tarIndexCacheFeature
                          reportsCoreFeature

src/Distribution/Server/Features/AdminFrontend.hs

@@ -17,9 +17,7 @@ import Distribution.Server.Features.UserSignup
 import Distribution.Server.Users.Types
 import qualified Distribution.Server.Users.Users as Users
 import Distribution.Text
-import Distribution.Simple.Utils (lowercase)
 
-import Data.List
 import qualified Data.Text as T
 import Control.Applicative (optional)
 import Data.Maybe (isJust)
@@ -104,9 +102,7 @@ adminFrontendFeature _env templates
         findAccount <- optional (look "find-account")
         accounts    <- case findAccount of
                          Nothing          -> return []
-                         Just searchTerms -> do
-                           users <- queryGetUserDb
-                           return (accountSearch users searchTerms)
+                         Just searchTerms -> querySearchUserNames (words searchTerms)
 
         findSignup <- optional (lookText' "find-signup")
         signups    <- case findSignup of
@@ -123,13 +119,6 @@ adminFrontendFeature _env templates
           , "signups"     $= map signupRequestToTemplate signups
           ]
       where
-        accountSearch users searchTerms =
-          [ (uid, uinfo)
-          | let terms = map lowercase (words searchTerms)
-          , (uid, uinfo@UserInfo{ userName = UserName uname })
-              <- Users.enumerateAllUsers users
-          , any (`isInfixOf` lowercase uname) terms ]
-
         signupSearch allSignupInfo searchTerms =
           [ signupInfo
           | let terms = map T.toCaseFold (T.words searchTerms)
@@ -157,7 +146,7 @@ adminFrontendFeature _env templates
         guardAuthorised_ [InGroup adminGroup]
         cacheControlWithoutETag [Private]
         template <- getTemplate templates "accounts.html"
-        accounts <- Users.enumerateAllUsers <$> queryGetUserDb
+        accounts <- queryAllUsers
         ok $ toResponse $ template
           [ "accounts" $= [ accountBasicInfoToTemplate uid uinfo
                           | (uid, uinfo) <- accounts ]

src/Distribution/Server/Features/Core.hs

@@ -50,8 +50,7 @@ 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                    (lookupUserId,
-                                                                     userIdToName)
+import           Distribution.Server.Users.Users                    (userIdToName)
 
 -- Cabal
 import           Distribution.Package
@@ -83,6 +82,18 @@ data CoreFeature = CoreFeature {
     -- | Retrieves the latest version of every package.
     queryLatestPackages :: forall m. MonadIO m => m [PkgInfo],
 
+    -- | Retrieves the name of every package, in ascending order.
+    queryAllPackageNames :: forall m. MonadIO m => m [PackageName],
+
+    queryAllPackageIds :: forall m. MonadIO m => m [PackageId],
+
+    -- | Counts the packages, i.e. the number of distinct package names.
+    queryCountPackages :: forall m. MonadIO m => m Int,
+
+    -- | Retrieves the package versions whose latest upload or revision
+    -- happened after the first time and no later than the second.
+    queryLatestUploadsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [PkgInfo],
+
     -- | Retrieve the raw tarball info
     queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo,
 
@@ -508,6 +519,18 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
     queryLatestPackages :: MonadIO m => m [PkgInfo]
     queryLatestPackages = Store.latestPackages packagesStore
 
+    queryAllPackageNames :: MonadIO m => m [PackageName]
+    queryAllPackageNames = Store.allPackageNames packagesStore
+
+    queryAllPackageIds :: MonadIO m => m [PackageId]
+    queryAllPackageIds = Store.allPackageIds packagesStore
+
+    queryCountPackages :: MonadIO m => m Int
+    queryCountPackages = Store.countPackages packagesStore
+
+    queryLatestUploadsBetween :: MonadIO m => UTCTime -> UTCTime -> m [PkgInfo]
+    queryLatestUploadsBetween = Store.latestUploadsBetween packagesStore
+
     queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo
     queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball
 
@@ -521,8 +544,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
                      -> CabalFileText -> UploadInfo
                      -> Maybe PkgTarball -> m Bool
     updateAddPackage pkgid cabalFile uploadinfo@(_, uid) mtarball = logTiming maxBound ("updateAddPackage " ++ display pkgid) $ do
-      usersdb <- queryGetUserDb
-      let Just userInfo = lookupUserId uid usersdb
+      muserInfo <- queryLookupUserId uid
+      let Just userInfo = muserInfo
 
       let pkginfo = Acid.mkPackageInfo pkgid cabalFile uploadinfo mtarball
       additionalEntries <- concat `liftM` runHook preIndexUpdateHook  (PackageChangeAdd pkginfo)
@@ -550,8 +573,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
 
     updateAddPackageRevision :: MonadIO m => PackageId -> CabalFileText -> UploadInfo -> m ()
     updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do
-      usersdb <- queryGetUserDb
-      let Just userInfo = lookupUserId uid usersdb
+      muserInfo <- queryLookupUserId uid
+      let Just userInfo = muserInfo
       (moldpkginfo, newpkginfo) <- Store.addPackageRevision packagesStore
                                      pkgid
                                      cabalfile
@@ -683,9 +706,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
     -- as we don't keep the parsed cabal files in memory)
     servePackageList :: DynamicPath -> ServerPartE Response
     servePackageList _ = do
-      pkgIndex <- queryGetPackageIndex
-      let pkgNames = PackageIndex.allPackageNames pkgIndex
-          list = map display pkgNames
+      pkgNames <- queryAllPackageNames
+      let list = map display pkgNames
       -- We construct the JSON manually so that we control what it looks like;
       -- in particular, we use objects for the packages so that we can add
       -- additional fields later without (hopefully) breaking clients

src/Distribution/Server/Features/Core/Acid.hs

@@ -9,24 +9,31 @@ import qualified Distribution.Server.Features.Core.State as Acid
 import Distribution.Server.Features.Security.Migration
 import Distribution.Server.Framework
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
+import Distribution.Server.Packages.Types (PkgInfo, pkgLatestUploadTime)
+
+import Distribution.Package (packageId)
 
 import qualified Data.List.NonEmpty as NE
 
 acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend
 acidStore env verbosity freshDB stateDir = do
   packagesState <- packagesStateComponent verbosity freshDB stateDir
+  let withIndex :: MonadIO m => (PackageIndex.PackageIndex PkgInfo -> a) -> m a
+      withIndex f = f . Acid.packageIndex <$> queryState packagesState Acid.GetPackagesState
   pure Backend {
       backendStore = Store {
           getPackagesState       = queryState packagesState Acid.GetPackagesState
-        , lookupPackageName      = \pkgname -> do
-                                     packages <- queryState packagesState Acid.GetPackagesState
-                                     pure (PackageIndex.lookupPackageName (Acid.packageIndex packages) pkgname)
-        , lookupPackageId        = \pkgid -> do
-                                     packages <- queryState packagesState Acid.GetPackagesState
-                                     pure (PackageIndex.lookupPackageId (Acid.packageIndex packages) pkgid)
-        , latestPackages         = do
-                                     packages <- queryState packagesState Acid.GetPackagesState
-                                     pure (NE.last <$> PackageIndex.allPackagesByNameNE (Acid.packageIndex packages))
+        , lookupPackageName      = \pkgname -> withIndex (`PackageIndex.lookupPackageName` pkgname)
+        , lookupPackageId        = \pkgid -> withIndex (`PackageIndex.lookupPackageId` pkgid)
+        , latestPackages         = withIndex (map NE.last . PackageIndex.allPackagesByNameNE)
+        , allPackageNames        = withIndex PackageIndex.allPackageNames
+        , allPackageIds          = withIndex (map packageId . PackageIndex.allPackages)
+        , countPackages          = withIndex PackageIndex.indexSize
+        , latestUploadsBetween   = \earlier later ->
+                                     let isBetween pkginfo =
+                                           let t = pkgLatestUploadTime pkginfo
+                                           in t > earlier && t <= later
+                                     in withIndex (filter isBetween . PackageIndex.allPackages)
         , addPackage             = \pkginfo uploadinfo username entries ->
                                      updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries)
         , deletePackage          = \pkgid ->

src/Distribution/Server/Features/Core/Store.hs

@@ -27,6 +27,14 @@ data Store = Store {
   , lookupPackageName      :: forall m. MonadIO m => PackageName -> m [PkgInfo]
   , lookupPackageId        :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo)
   , latestPackages         :: forall m. MonadIO m => m [PkgInfo]
+    -- | Every package name, in ascending order.
+  , allPackageNames        :: forall m. MonadIO m => m [PackageName]
+  , allPackageIds          :: forall m. MonadIO m => m [PackageId]
+    -- | The number of distinct package names, not package versions.
+  , countPackages          :: forall m. MonadIO m => m Int
+    -- | Package versions whose latest upload or revision is after the first
+    -- time and no later than the second.
+  , latestUploadsBetween   :: forall m. MonadIO m => UTCTime -> UTCTime -> m [PkgInfo]
   , addPackage             :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool
   , deletePackage          :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo)
   , addPackageRevision     :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo)

src/Distribution/Server/Features/Html.hs

@@ -44,7 +44,6 @@ 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 qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Users.Group (UserGroup(..))
 
 import qualified Distribution.Server.Pages.Package as Pages
@@ -902,7 +901,7 @@ mkHtmlUsers UserFeature{..} UserDetailsFeature{..} = HtmlUsers{..}
 
     serveUserList :: DynamicPath -> ServerPartE Response
     serveUserList _ = do
-        userlist <- Users.enumerateActiveUsers <$> queryGetUserDb
+        userlist <- queryActiveUsers
         let hlist = unordList
                       [ anchor ! [href $ userPageUri users "" uname] << display uname
                       | (_, uinfo) <- userlist, let uname = userName uinfo ]
@@ -1325,9 +1324,7 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..}
       candRender <- liftIO $ candidateRender cand
       let PackageIdentifier pkgname version = packageId cand
           render = candPackageRender candRender
-      otherVersions <- map packageVersion
-                     . flip PackageIndex.lookupPackageName pkgname
-                   <$> queryGetPackageIndex
+          otherVersions = indexedVersions candRender
       prefInfo <- queryGetPreferredInfo pkgname
       let maintainHtml = anchor ! [href $ renderResource maintain [display $ packageId cand]] << "maintain"
       -- bottom sections, currently documentation and readme
@@ -1350,7 +1347,6 @@ mkHtmlCandidates ServerEnv{..} utilities@HtmlUtilities{..}
 
       let docURL = packageDocsContentUri docs (packageId cand)
 
-      -- also utilize hasIndexedPackage :: Bool
       let warningBox = case renderWarnings candRender of
               [] -> []
               warn -> [thediv ! [theclass "candidate-warn"] << [paragraph << strong (toHtml "Warnings:"), unordList warn]]
@@ -2119,7 +2115,7 @@ mkHtmlReverse HtmlUtilities{..}
                         , corePackageIdUri
                         , corePackageNameUri
                         },
-                        queryGetPackageIndex
+                        queryCountPackages
                       }
            VersionsFeature{withPackageVersion}
            ListFeature{}
@@ -2188,6 +2184,6 @@ mkHtmlReverse HtmlUtilities{..}
     serveReverseList :: DynamicPath -> ServerPartE Response
     serveReverseList _ = do
         namesWithCounts <- revCountForAllPackages
-        hackCount <- PackageIndex.indexSize <$> queryGetPackageIndex
+        hackCount <- queryCountPackages
         return $ toResponse $ Resource.XHtml $ hackagePage "Reverse dependencies" $
             reversePackagesRender (corePackageNameUri "") hackCount namesWithCounts

src/Distribution/Server/Features/Mirror.hs

@@ -186,8 +186,9 @@ mirrorFeature ServerEnv{serverBlobStore = store}
 
     uploaderGet dpath = do
       pkg    <- packageInPath dpath >>= lookupPackageId
-      userdb <- queryGetUserDb
-      return $ toResponse $ display (userIdToName userdb (pkgLatestUploadUser pkg))
+      let uid = pkgLatestUploadUser pkg
+      muser  <- queryLookupUserId uid
+      return $ toResponse $ display (userNameOrPlaceholder uid muser)
 
     uploaderPut :: DynamicPath -> ServerPartE Response
     uploaderPut dpath = do

src/Distribution/Server/Features/PackageCandidates.hs

@@ -126,7 +126,7 @@ data PackageCandidatesResource = PackageCandidatesResource {
 data CandidateRender = CandidateRender {
     candPackageRender :: PackageRender,
     renderWarnings :: [String],
-    hasIndexedPackage :: Bool
+    indexedVersions :: [Version]
 }
 
 
@@ -168,6 +168,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
                   UserFeature{..}
                   CoreFeature{ coreResource=core@CoreResource{packageInPath, packageTarballInPath}
                              , queryGetPackageIndex
+                             , queryLookupPackageName
                              , updateAddPackage
                              }
                   UploadFeature{..}
@@ -516,7 +517,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     candidateRender :: CandPkgInfo -> IO CandidateRender
     candidateRender cand = do
         users  <- queryGetUserDb
-        index  <- queryGetPackageIndex
+        indexedPkgs <- queryLookupPackageName (packageName cand)
         let pkg = candPkgInfo cand
         changeLog <- findToplevelFile pkg isChangeLogFile
                  >>= either (\_ -> return Nothing) (return . Just)
@@ -528,7 +529,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
                                      , rendChangeLog = changeLog
                                      , rendReadme    = readme},
           renderWarnings    = candWarnings cand,
-          hasIndexedPackage = not . null $ PackageIndex.lookupPackageName index (packageName cand)
+          indexedVersions   = map packageVersion indexedPkgs
         }
 
     ------------------------------------------------------------------------------

src/Distribution/Server/Features/PreferredVersions.hs

@@ -30,7 +30,6 @@ import Distribution.Server.Features.Upload
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.Tags
 
-import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Packages.Types
 
 import Distribution.Package
@@ -271,9 +270,9 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
 
     withPackageVersion :: PackageId -> (PkgInfo -> ServerPartE a) -> ServerPartE a
     withPackageVersion pkgid func = do
-        pkgIndex <- queryGetPackageIndex
         guard (packageVersion pkgid /= nullVersion)
-        case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of
+        pkgs <- queryLookupPackageName (packageName pkgid)
+        case pkgs of
             []   ->  packageError [MText $ "No such package in package index. ", MLink "Search for related terms instead?"$ "/packages/search?terms=" ++ (display $ pkgName pkgid)]
             pkg -> case find ((== packageVersion pkgid) . packageVersion) pkg of
                 Nothing  -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)]
@@ -286,8 +285,8 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
     -- which is outside of the scope of this feature.
     withPackagePreferred :: PackageId -> (PkgInfo -> [PkgInfo] -> ServerPartE a) -> ServerPartE a
     withPackagePreferred pkgid func = do
-      pkgIndex <- queryGetPackageIndex
-      case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of
+      allPkgs <- queryLookupPackageName (packageName pkgid)
+      case allPkgs of
             []   ->  packageError [MText "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)]
             pkgs  | pkgVersion pkgid == nullVersion -> Store.getPreferredInfo preferredStore (packageName pkgid) >>= \info -> do
                 let rangeToCheck = sumRange info
@@ -346,13 +345,12 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
     putDeprecated pkgname = do
       guardValidPackageName pkgname
       guardAuthorisedAsMaintainerOrTrustee pkgname
-      index  <- queryGetPackageIndex
       isDepr <- optional $ look "deprecated"
       case isDepr of
           Just {} -> do
               depr <- optional $ fmap words $ look "by"
               case mapM simpleParse =<< depr of
-                  Just deprs -> case filter (null . PackageIndex.lookupPackageName index) deprs of
+                  Just deprs -> filterM (fmap null . queryLookupPackageName) deprs >>= \case
                       [] -> case pkgname `elem` deprs of
                               True -> deprecatedError "You can not deprecate a package in favor of itself!"
                               _ -> do

src/Distribution/Server/Features/Upload.hs

@@ -132,7 +132,7 @@ initUploadFeature env@ServerEnv{serverStateDir} = do
           (uploadersGroup, uploadersGroupResource) <-
             groupResourceAt "/packages/uploaders" uploadersGroupDescription
 
-          pkgNames <- PackageIndex.packageNames <$> queryGetPackageIndex
+          pkgNames <- queryAllPackageNames
           (maintainersGroup, maintainersGroupResource) <-
             groupResourcesAt "/package/:package/maintainers"
                              maintainersGroupDescription