Batch per-package queries in notifications and deprecation

src/Distribution/Server/Features/BuildReports.hs

@@ -14,6 +14,8 @@ import Distribution.Server.Features.Core
 
 import qualified Distribution.Server.Features.BuildReports.Acid as Acid
 import qualified Distribution.Server.Features.BuildReports.Store as Store
+
+import Data.Time.Clock (UTCTime)
 import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport
 import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..))
 import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..))
@@ -44,6 +46,9 @@ data ReportsFeature = ReportsFeature {
     packageReport  :: DynamicPath -> ServerPartE (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog),
 
     queryPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)],
+    -- | Retrieves the reports whose time is after the first time and no later
+    -- than the second, in package id order.
+    queryReportsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)],
     queryBuildLog       :: forall m. MonadIO m => BuildLog  -> m Resource.BuildLog,
     queryTestLog        :: forall m. MonadIO m => TestLog   -> m Resource.TestLog,
     queryTestReportLog  :: forall m. MonadIO m => TestReportLog -> m Resource.TestReportLog,
@@ -206,6 +211,9 @@ buildReportsFeature name
     queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)]
     queryPackageReports = Store.lookupPackageReports reportsStore
 
+    queryReportsBetween :: MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)]
+    queryReportsBetween = Store.reportsBetween reportsStore
+
     queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog
     queryBuildLog (BuildLog blobId) = do
         file <- liftIO $ BlobStorage.fetch store blobId

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

@@ -6,9 +6,12 @@ module Distribution.Server.Features.BuildReports.Acid
 import qualified Distribution.Server.Features.BuildReports.State as State
 import Distribution.Server.Features.BuildReports.Backup (dumpBackup, restoreBackup)
 import Distribution.Server.Features.BuildReports.BuildReports (BuildReports)
+import qualified Distribution.Server.Features.BuildReports.BuildReports as BuildReports
 import qualified Distribution.Server.Features.BuildReports.Store as Store
 import Distribution.Server.Framework
 
+import qualified Data.Map as Map
+
 acidStore :: String -> FilePath -> IO Store.Backend
 acidStore name stateDir = do
   reportsState <- reportsStateComponent name stateDir
@@ -18,6 +21,14 @@ acidStore name stateDir = do
         , Store.lookupPackageReports = \pkgid -> do
             reports <- queryState reportsState (State.LookupPackageReports pkgid)
             pure $ map (\(reportId, (report, _, _, _)) -> (reportId, report)) reports
+        , Store.reportsBetween = \earlier later -> do
+            buildReports <- queryState reportsState State.GetBuildReports
+            pure [ (pkgid, report)
+                 | (pkgid, pkgReports) <- Map.toList (BuildReports.reportsIndex buildReports)
+                 , (report, _, _, _, _) <- Map.elems (BuildReports.reports pkgReports)
+                 , Just t <- [BuildReports.time report]
+                 , t > earlier && t <= later
+                 ]
         , Store.lookupFailCount = \pkgid -> queryState reportsState (State.LookupFailCount pkgid)
         , Store.lookupLatestReport = \pkgid -> queryState reportsState (State.LookupLatestReport pkgid)
         , Store.lookupRunTests = \pkgid -> queryState reportsState (State.LookupRunTests pkgid)

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

@@ -12,6 +12,7 @@ import Distribution.Server.Features.BuildReports.BuildReports
 import Distribution.Server.Framework (AbstractStateComponent)
 
 import Control.Monad.Trans (MonadIO)
+import Data.Time.Clock (UTCTime)
 
 data Backend = Backend {
     backendStore :: Store
@@ -21,6 +22,9 @@ data Backend = Backend {
 data Store = Store {
     lookupReportCovg :: forall m. MonadIO m => PackageId -> BuildReportId -> m (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog))
   , lookupPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)]
+    -- | Reports whose time is after the first time and no later than the
+    -- second, in package id order.
+  , reportsBetween :: forall m. MonadIO m => UTCTime -> UTCTime -> m [(PackageId, BuildReport)]
   , lookupFailCount :: forall m. MonadIO m => PackageId -> m (Maybe BuildStatus)
   , lookupLatestReport :: forall m. MonadIO m => PackageId -> m (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog))
   , lookupRunTests :: forall m. MonadIO m => PackageId -> m Bool

src/Distribution/Server/Features/Core.hs

@@ -25,6 +25,7 @@ import qualified Codec.Compression.GZip                             as GZip
 import           Data.Aeson                                         (Value (..), toJSON)
 import qualified Data.Aeson.Key                                     as Key
 import qualified Data.Aeson.KeyMap                                  as KeyMap
+import           Data.Map                                           (Map)
 import           Data.ByteString.Lazy                               (LazyByteString, fromStrict)
 import qualified Data.Foldable                                      as Foldable
 import qualified Data.Text                                          as Text
@@ -79,6 +80,10 @@ data CoreFeature = CoreFeature {
     -- | Retrieves a specific package version.
     queryLookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo),
 
+    -- | Retrieves all versions of the given packages, leaving out names that
+    -- do not exist.
+    queryLookupPackageNames :: forall m. MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo]),
+
     -- | Retrieves the latest version of every package.
     queryLatestPackages :: forall m. MonadIO m => m [PkgInfo],
 
@@ -516,6 +521,9 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..}
     queryLookupPackageId :: MonadIO m => PackageId -> m (Maybe PkgInfo)
     queryLookupPackageId = Store.lookupPackageId packagesStore
 
+    queryLookupPackageNames :: MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo])
+    queryLookupPackageNames = Store.lookupPackageNames packagesStore
+
     queryLatestPackages :: MonadIO m => m [PkgInfo]
     queryLatestPackages = Store.latestPackages packagesStore
 

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

@@ -14,6 +14,7 @@ import Distribution.Server.Packages.Types (PkgInfo, pkgLatestUploadTime)
 import Distribution.Package (packageId)
 
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as Map
 
 acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend
 acidStore env verbosity freshDB stateDir = do
@@ -25,6 +26,11 @@ acidStore env verbosity freshDB stateDir = do
           getPackagesState       = queryState packagesState Acid.GetPackagesState
         , lookupPackageName      = \pkgname -> withIndex (`PackageIndex.lookupPackageName` pkgname)
         , lookupPackageId        = \pkgid -> withIndex (`PackageIndex.lookupPackageId` pkgid)
+        , lookupPackageNames     = \pkgnames -> withIndex $ \index ->
+                                     Map.fromList [ (pkgname, pkgs)
+                                                  | pkgname <- pkgnames
+                                                  , let pkgs = PackageIndex.lookupPackageName index pkgname
+                                                  , not (null pkgs) ]
         , latestPackages         = withIndex (map NE.last . PackageIndex.allPackagesByNameNE)
         , allPackageNames        = withIndex PackageIndex.allPackageNames
         , allPackageIds          = withIndex (map packageId . PackageIndex.allPackages)

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

@@ -15,6 +15,7 @@ import Distribution.Server.Users.Users (Users)
 import Distribution.Package (PackageId, PackageName)
 
 import Control.Monad.Trans (MonadIO)
+import Data.Map (Map)
 import Data.Time.Clock (UTCTime)
 
 data Backend = Backend {
@@ -26,6 +27,8 @@ data Store = Store {
     getPackagesState       :: forall m. MonadIO m => m PackagesState
   , lookupPackageName      :: forall m. MonadIO m => PackageName -> m [PkgInfo]
   , lookupPackageId        :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo)
+    -- | The given packages that exist, with all their versions.
+  , lookupPackageNames     :: forall m. MonadIO m => [PackageName] -> m (Map PackageName [PkgInfo])
   , latestPackages         :: forall m. MonadIO m => m [PkgInfo]
     -- | Every package name, in ascending order.
   , allPackageNames        :: forall m. MonadIO m => m [PackageName]

src/Distribution/Server/Features/PreferredVersions.hs

@@ -350,7 +350,9 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
           Just {} -> do
               depr <- optional $ fmap words $ look "by"
               case mapM simpleParse =<< depr of
-                  Just deprs -> filterM (fmap null . queryLookupPackageName) deprs >>= \case
+                  Just deprs -> do
+                    existing <- queryLookupPackageNames deprs
+                    case filter (`Map.notMember` existing) deprs of
                       [] -> case pkgname `elem` deprs of
                               True -> deprecatedError "You can not deprecate a package in favor of itself!"
                               _ -> do

src/Distribution/Server/Features/UserNotify.hs

@@ -67,7 +67,7 @@ import Data.Bimap (lookup, lookupR)
 import Data.Graph (Vertex)
 import Data.Hashable (Hashable(..))
 import Data.List (maximumBy, sortOn)
-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe, maybeToList)
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import Data.Ord (Down(..), comparing)
 import Data.Time (addUTCTime, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime)
 import Distribution.Text (display)
@@ -482,7 +482,8 @@ userNotifyFeature UserFeature{..}
                              then addUTCTime (negate $ (60*60*6)) now
                              else lastNotifyTime -- for testing you can increase this
         revisionsAndUploads <- queryLatestUploadsBetween trimLastTime now
-        revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs trimLastTime now) revisionsAndUploads
+        uploadedPackages <- queryLookupPackageNames (map (packageName . pkgInfoId) revisionsAndUploads)
+        revisionUploadNotifications <- concatMapM (genRevUploadList notifyPrefs uploadedPackages trimLastTime now) revisionsAndUploads
 
         groupActions <- collectAdminActions trimLastTime now
         groupActionNotifications <- concatMapM (genGroupUploadList notifyPrefs) groupActions
@@ -521,27 +522,28 @@ userNotifyFeature UserFeature{..}
         return $ filter isRecent $ aLog
 
     collectDocReport earlier now = do
-        pkgs <- PackageIndex.allPackages <$> queryGetPackageIndex
-        pkgRpts <- forM pkgs $ \pkg -> do
-          rpts <- queryPackageReports (packageId pkg)
-          pure $ (pkg,) $ do
-            -- List monad, filter out recent docbuilds
-            (_, rpt@BuildReport.BuildReport{..}) <- rpts
-            t <- maybeToList time
-            guard $ docsOutcome /= BuildReport.NotTried && t > earlier && t <= now
-            pure rpt
-        let isBuildOk BuildReport.BuildReport{..} = docsOutcome == BuildReport.Ok
-        pure $ map (second (all isBuildOk)) $ filter (not . Prelude.null . snd) pkgRpts
+        rpts <- queryReportsBetween earlier now
+        let docRpts = Map.fromListWith (flip (++))
+              [ (pkgid, [rpt])
+              | (pkgid, rpt) <- rpts
+              , BuildReport.docsOutcome rpt /= BuildReport.NotTried
+              ]
+            isBuildOk rpt = BuildReport.docsOutcome rpt == BuildReport.Ok
+        indexedPackages <- queryLookupPackageNames (map packageName (Map.keys docRpts))
+        let isInMainIndex pkgid =
+              any ((== pkgid) . pkgInfoId) (Map.findWithDefault [] (packageName pkgid) indexedPackages)
+        pure $ filter (isInMainIndex . fst) $
+          map (second (all isBuildOk)) (Map.toList docRpts)
 
     collectTagProposals = do
         logs <- readMemState tagProposalLog
         writeMemState tagProposalLog Map.empty
         pure $ Map.toList logs
 
-    genRevUploadList notifyPrefs earlier now pkg = do
+    genRevUploadList notifyPrefs uploadedPackages earlier now pkg = do
          let pkgName = packageName . pkgInfoId $ pkg
-         allVersions <- queryLookupPackageName pkgName
-         let actor = pkgLatestUploadUser pkg
+             allVersions = Map.findWithDefault [] pkgName uploadedPackages
+             actor = pkgLatestUploadUser pkg
              isRevision = pkgNumRevisions pkg > 1
              mbLatest = listToMaybe (reverse allVersions)
              isLatestVersion = maybe False (\x -> pkgInfoId pkg == pkgInfoId x) mbLatest
@@ -601,16 +603,16 @@ userNotifyFeature UserFeature{..}
               }
         _ -> pure []
 
-    genDocReportList notifyPrefs (pkg, success) = do
-      maintainers <- queryUserGroup $ maintainersGroup (packageName $ pkgInfoId pkg)
+    genDocReportList notifyPrefs (pkgid, success) = do
+      maintainers <- queryUserGroup $ maintainersGroup (packageName pkgid)
       pure . flip mapMaybe (toList maintainers) $ \uid ->
         fmap (uid,) $ do
           let Acid.NotifyPref{..} = fromMaybe Acid.defaultNotifyPrefs (Map.lookup uid notifyPrefs)
           guard $ not notifyOptOut
           guard notifyDocBuilderReport
           Just
             NotifyDocsBuild
-              { notifyPackageId = pkgInfoId pkg
+              { notifyPackageId = pkgid
               , notifyBuildSuccess = success
               }