More easy narrowing of store getters

src/Distribution/Server/Features/Html.hs

@@ -1782,8 +1782,8 @@ mkHtmlTags HtmlUtilities{..}
 
     serveTagsListing :: DynamicPath -> ServerPartE Response
     serveTagsListing _ = do
-        tagList <- queryGetTagList
-        let withCounts = filter ((>0) . snd) . map (\(tg, pkgs) -> (tg, Set.size pkgs)) $ tagList
+        tagCounts <- queryTagCounts
+        let withCounts = filter ((>0) . snd) tagCounts
             countSort = sortBy (flip compare `on` snd) withCounts
         return $ toResponse $ Resource.XHtml $ hackagePage "Hackage tags"
           [ h2 << "Hackage tags"

src/Distribution/Server/Features/PackageCandidates.hs

@@ -145,7 +145,7 @@ initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do
       -- one-off migration
       migratedPkgTarball <- Store.candidateTarballIsMigrated candidatesStore
       unless migratedPkgTarball $ do
-        candidateIndex <- Store.getCandidateIndex candidatesStore
+        candidateIndex <- PackageIndex.fromList <$> Store.allCandidates candidatesStore
         migrateCandidatePkgTarball_v1_to_v2 env candidateIndex $ \pkgid pkginfo ->
           void $ Store.updateCandidatePkgInfo candidatesStore pkgid pkginfo
         Store.setCandidateTarballMigrated candidatesStore
@@ -195,7 +195,7 @@ candidatesFeature ServerEnv{serverBlobStore = store}
       }
 
     queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo)
-    queryGetCandidateIndex = Store.getCandidateIndex candidatesStore
+    queryGetCandidateIndex = PackageIndex.fromList <$> Store.allCandidates candidatesStore
 
     candidatesCoreResource = fix $ \r -> CoreResource {
 -- TODO: There is significant overlap between this definition and the one in Core
@@ -541,17 +541,16 @@ candidatesFeature ServerEnv{serverBlobStore = store}
     lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo]
     lookupCandidateName pkgname = do
       guardValidPackageName core pkgname
-      candidateIndex <- queryGetCandidateIndex
-      return $ PackageIndex.lookupPackageName candidateIndex pkgname
+      Store.lookupCandidateName candidatesStore pkgname
 
     -- TODO: Unlike the corresponding function in core, we don't return the
     -- "latest" candidate when Version is empty. Should we?
     -- (If we change that, we should move the 'guard' to 'guardValidPackageId')
     lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo
     lookupCandidateId pkgid = do
       guard (pkgVersion pkgid /= nullVersion)
-      candidateIndex <- queryGetCandidateIndex
-      case PackageIndex.lookupPackageId candidateIndex pkgid of
+      mcand <- Store.lookupCandidateId candidatesStore pkgid
+      case mcand of
         Just pkg -> return pkg
         _ -> errNotFound "Candidate not found" [MText $ "No such candidate version for " ++ display (packageName pkgid)]
 

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

@@ -7,13 +7,19 @@ import qualified Distribution.Server.Features.PackageCandidates.State as State
 import Distribution.Server.Features.PackageCandidates.Backup
 import qualified Distribution.Server.Features.PackageCandidates.Store as Store
 import Distribution.Server.Framework
+import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo)
+import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 
 acidStore :: FilePath -> IO Store.Backend
 acidStore stateDir = do
   candidatesState <- candidatesStateComponent False stateDir
+  let withCandidates :: MonadIO m => (PackageIndex.PackageIndex CandPkgInfo -> a) -> m a
+      withCandidates f = f . State.candidateList <$> queryState candidatesState State.GetCandidatePackages
   pure Store.Backend {
       Store.backendStore = Store.Store {
-          Store.getCandidateIndex = State.candidateList <$> queryState candidatesState State.GetCandidatePackages
+          Store.lookupCandidateName = \pkgname -> withCandidates (`PackageIndex.lookupPackageName` pkgname)
+        , Store.lookupCandidateId = \pkgid -> withCandidates (`PackageIndex.lookupPackageId` pkgid)
+        , Store.allCandidates = withCandidates PackageIndex.allPackages
         , Store.candidateTarballIsMigrated = State.candidateMigratedPkgTarball <$> queryState candidatesState State.GetCandidatePackages
         , Store.setCandidateTarballMigrated = updateState candidatesState State.SetMigratedPkgTarball
         , Store.addCandidate = \candidate -> updateState candidatesState (State.AddCandidate candidate)

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

@@ -8,7 +8,6 @@ module Distribution.Server.Features.PackageCandidates.Store
 import Distribution.Package (PackageId, PackageName)
 import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo)
 import Distribution.Server.Framework (AbstractStateComponent)
-import Distribution.Server.Packages.PackageIndex (PackageIndex)
 import Distribution.Server.Packages.Types (PkgInfo)
 
 import Control.Monad.Trans (MonadIO)
@@ -19,7 +18,9 @@ data Backend = Backend {
   }
 
 data Store = Store {
-    getCandidateIndex :: forall m. MonadIO m => m (PackageIndex CandPkgInfo)
+    lookupCandidateName :: forall m. MonadIO m => PackageName -> m [CandPkgInfo]
+  , lookupCandidateId :: forall m. MonadIO m => PackageId -> m (Maybe CandPkgInfo)
+  , allCandidates :: forall m. MonadIO m => m [CandPkgInfo]
   , candidateTarballIsMigrated :: forall m. MonadIO m => m Bool
   , setCandidateTarballMigrated :: forall m. MonadIO m => m ()
   , addCandidate :: forall m. MonadIO m => CandPkgInfo -> m ()

src/Distribution/Server/Features/PreferredVersions.hs

@@ -57,7 +57,7 @@ data VersionsFeature = VersionsFeature {
 
     queryGetPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo,
     queryGetDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName]),
-    queryGetPreferredVersions :: forall m. MonadIO m => m PreferredVersions,
+    queryAllPreferredInfo :: forall m. MonadIO m => m (Map.Map PackageName PreferredInfo),
 
     versionsResource :: VersionsResource,
     deprecatedHook :: Hook (PackageName, Maybe [PackageName]) (),
@@ -158,11 +158,11 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
     queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName])
     queryGetDeprecatedFor = Store.getDeprecatedFor preferredStore
 
-    queryGetPreferredVersions :: MonadIO m => m PreferredVersions
-    queryGetPreferredVersions = Store.getPreferredVersions preferredStore
+    queryAllPreferredInfo :: MonadIO m => m (Map.Map PackageName PreferredInfo)
+    queryAllPreferredInfo = Store.getAllPreferredInfo preferredStore
 
     updateDeprecatedTags = do
-      pkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore
+      pkgs <- Store.getAllDeprecated preferredStore
       setCalculatedTag (Tag "deprecated") (Map.keysSet pkgs)
 
     CoreResource{..} = coreResource
@@ -212,7 +212,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
 
     handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response
     handlePackagesDeprecatedGet _ = do
-      deprPkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore
+      deprPkgs <- Store.getAllDeprecated preferredStore
       return $ toResponse $ array
           [ object
               [ ("deprecated-package", string $ display deprPkg)
@@ -387,16 +387,16 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
       Store.getDeprecatedFor preferredStore pkgname
 
     doPreferredsRender :: MonadIO m => m [(PackageName, PreferredRender)]
-    doPreferredsRender = Store.getPreferredVersions preferredStore >>=
-        return . map (second renderPrefInfo) . Map.toList . preferredMap
+    doPreferredsRender = Store.getAllPreferredInfo preferredStore >>=
+        return . map (second renderPrefInfo) . Map.toList
 
     doDeprecatedsRender :: MonadIO m => m [(PackageName, [PackageName])]
-    doDeprecatedsRender = Store.getPreferredVersions preferredStore >>=
-        return . Map.toList . deprecatedMap
+    doDeprecatedsRender = Store.getAllDeprecated preferredStore >>=
+        return . Map.toList
 
     makeGlobalPreferredVersions :: (Functor m, MonadIO m) => m String
     makeGlobalPreferredVersions = do
-      prefs <- preferredMap <$> Store.getPreferredVersions preferredStore
+      prefs <- Store.getAllPreferredInfo preferredStore
       return $! formatGlobalPreferredVersions (Map.toList prefs)
 
     formatSinglePreferredVersions :: PackageName -> PreferredInfo -> Maybe String
@@ -422,10 +422,10 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity }
 
     -- One-off complex migration
     ephemeralPrefsMigration = do
-      PreferredVersions {migratedEphemeralPrefs, preferredMap}
-        <- Store.getPreferredVersions preferredStore
+      migratedEphemeralPrefs <- Store.isMigratedEphemeralPrefs preferredStore
       unless migratedEphemeralPrefs $
         logTiming verbosity "preferred-versions migration" $ do
+          preferredMap <- Store.getAllPreferredInfo preferredStore
           sequence_
             [ updateIndexPackagePreferredVersions pkgname prefinfo
             | (pkgname, prefinfo) <- Map.toList preferredMap ]

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

@@ -15,7 +15,9 @@ acidStore stateDir = do
       Store.backendStore = Store.Store {
           Store.getPreferredInfo = \name -> queryState preferredState (State.GetPreferredInfo name)
         , Store.getDeprecatedFor = \name -> queryState preferredState (State.GetDeprecatedFor name)
-        , Store.getPreferredVersions = queryState preferredState State.GetPreferredVersions
+        , Store.getAllPreferredInfo = State.preferredMap <$> queryState preferredState State.GetPreferredVersions
+        , Store.getAllDeprecated = State.deprecatedMap <$> queryState preferredState State.GetPreferredVersions
+        , Store.isMigratedEphemeralPrefs = State.migratedEphemeralPrefs <$> queryState preferredState State.GetPreferredVersions
         , Store.setDeprecatedFor = \name deprs -> updateState preferredState (State.SetDeprecatedFor name deprs)
         , Store.setPreferredInfo = \name ranges versions -> updateState preferredState (State.SetPreferredInfo name ranges versions)
         , Store.setMigratedEphemeralPrefs = updateState preferredState State.SetMigratedEphemeralPrefs

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

@@ -6,11 +6,12 @@ module Distribution.Server.Features.PreferredVersions.Store
   ) where
 
 import Distribution.Package (PackageName)
-import Distribution.Server.Features.PreferredVersions.State (PreferredInfo, PreferredVersions)
+import Distribution.Server.Features.PreferredVersions.State (PreferredInfo)
 import Distribution.Server.Framework (AbstractStateComponent)
 import Distribution.Version (Version, VersionRange)
 
 import Control.Monad.Trans (MonadIO)
+import Data.Map (Map)
 
 data Backend = Backend {
     backendStore :: Store
@@ -20,7 +21,9 @@ data Backend = Backend {
 data Store = Store {
     getPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo
   , getDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName])
-  , getPreferredVersions :: forall m. MonadIO m => m PreferredVersions
+  , getAllPreferredInfo :: forall m. MonadIO m => m (Map PackageName PreferredInfo)
+  , getAllDeprecated :: forall m. MonadIO m => m (Map PackageName [PackageName])
+  , isMigratedEphemeralPrefs :: forall m. MonadIO m => m Bool
   , setDeprecatedFor :: forall m. MonadIO m => PackageName -> Maybe [PackageName] -> m ()
   , setPreferredInfo :: forall m. MonadIO m => PackageName -> [VersionRange] -> [Version] -> m PreferredInfo
   , setMigratedEphemeralPrefs :: forall m. MonadIO m => m ()

src/Distribution/Server/Features/ReverseDependencies.hs

@@ -12,7 +12,6 @@ module Distribution.Server.Features.ReverseDependencies (
 import Distribution.Server.Framework
 import Distribution.Server.Features.Core
 import Distribution.Server.Features.PreferredVersions
-import Distribution.Server.Features.PreferredVersions.State (PreferredVersions)
 import qualified Distribution.Server.Packages.PackageIndex as PackageIndex
 import Distribution.Server.Packages.PackageIndex (PackageIndex, packageNames, allPackagesByNameNE)
 import Distribution.Server.Packages.Types (PkgInfo)
@@ -84,11 +83,11 @@ initReverseFeature _ = do
     updateReverse <- newHook
 
     return $ \CoreFeature{queryGetPackageIndex,packageChangeHook}
-             VersionsFeature{queryGetPreferredVersions} -> do
+             VersionsFeature{queryAllPreferredInfo} -> do
       idx <- queryGetPackageIndex
       memState <- newMemStateWHNF $ constructReverseIndex idx
 
-      let feature = reverseFeature queryGetPackageIndex queryGetPreferredVersions memState updateReverse
+      let feature = reverseFeature queryGetPackageIndex queryAllPreferredInfo memState updateReverse
 
       registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) ->
         case mpkginfo of
@@ -125,13 +124,13 @@ instance ToJSON Edge
 -- instance ToJSON PackageName
 
 reverseFeature :: IO (PackageIndex PkgInfo)
-               -> IO PreferredVersions
+               -> IO (Map.Map PackageName PreferredInfo)
                -> MemState ReverseIndex
                -> Hook [NE.NonEmpty PkgInfo] ()
                -> ReverseFeature
 
 reverseFeature queryGetPackageIndex
-               queryGetPreferredVersions
+               queryAllPreferredInfo
                reverseMemState
                reverseHook
   = ReverseFeature{..}
@@ -211,7 +210,7 @@ reverseFeature queryGetPackageIndex
     revDisplayInfo :: MonadIO m => m VersionIndex
     revDisplayInfo = do
         pkgIndex <- liftIO queryGetPackageIndex
-        prefs <- liftIO queryGetPreferredVersions
+        prefs <- liftIO queryAllPreferredInfo
         return $ getDisplayInfo prefs pkgIndex
 
     renderReverseWith :: MonadIO m => PackageName -> ReverseDisplay -> (Maybe VersionStatus -> Bool) -> m ReversePageRender

src/Distribution/Server/Features/ReverseDependencies/State.hs

@@ -181,9 +181,9 @@ constructReverseDisplay :: (PackageName -> (PreferredInfo, [Version])) -> Map Pa
 constructReverseDisplay indexFunc =
     Map.mapMaybeWithKey (uncurry maybeBestVersion . indexFunc)
 
-getDisplayInfo :: PreferredVersions -> PackageIndex PkgInfo -> VersionIndex
+getDisplayInfo :: Map PackageName PreferredInfo -> PackageIndex PkgInfo -> VersionIndex
 getDisplayInfo preferred index pkgname = (,)
-    (Map.findWithDefault emptyPreferredInfo pkgname $ preferredMap preferred)
+    (Map.findWithDefault emptyPreferredInfo pkgname preferred)
     (map packageVersion . PackageIndex.lookupPackageName index $ pkgname)
 
 

src/Distribution/Server/Features/Sitemap.hs

@@ -155,7 +155,7 @@ sitemapFeature  ServerEnv{..}
     updateSitemapCache :: IO Sitemap
     updateSitemapCache = do
 
-      alltags  <- queryGetTagList
+      alltags  <- queryTagCounts
       pkgIndex <- queryGetPackageIndex
       docIndex <- queryDocumentationIndex
 

src/Distribution/Server/Features/Tags.hs

@@ -45,7 +45,8 @@ data TagsFeature = TagsFeature {
 
     tagsResource :: TagsResource,
 
-    queryGetTagList     :: forall m. MonadIO m => m [(Tag, Set PackageName)],
+    -- | Retrieves every tag with its number of packages, in tag order.
+    queryTagCounts      :: forall m. MonadIO m => m [(Tag, Int)],
     queryTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag),
     queryReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag,Set Tag),
     queryAliasForTag :: forall m. MonadIO m => Tag -> m Tag,
@@ -178,8 +179,8 @@ tagsFeature CoreFeature{ queryLatestPackages }
             let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags)
             forM_ calcTags' $ uncurry setCalculatedTag
 
-    queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)]
-    queryGetTagList = Store.getTagList tagsStore
+    queryTagCounts :: MonadIO m => m [(Tag, Int)]
+    queryTagCounts = Store.getTagCounts tagsStore
 
     queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag)
     queryTagsForPackage = Store.getTagsForPackage tagsStore
@@ -204,9 +205,7 @@ tagsFeature CoreFeature{ queryLatestPackages }
             func tag pkgs
 
     collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag))
-    collectTags pkgs = do
-        pkgMap <- liftM State.packageTags $ Store.getPackageTags tagsStore
-        return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs
+    collectTags pkgs = Store.getTagsForPackages tagsStore (Set.toList pkgs)
 
     mergeTags :: Maybe String -> Tag -> ServerPartE ()
     mergeTags targetTag deprTag =

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

@@ -10,18 +10,24 @@ import Distribution.Server.Features.Tags.Backup
 import Distribution.Server.Framework
 import Distribution.Server.Framework.BackupDump
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
 acidStore :: FilePath -> IO Store.Backend
 acidStore stateDir = do
   tagsState <- tagsStateComponent stateDir
   tagAlias <- tagsAliasComponent stateDir
   pure Store.Backend {
       Store.backendStore = Store.Store {
-          Store.getTagList = queryState tagsState State.GetTagList
+          Store.getTagCounts = map (fmap Set.size) <$> queryState tagsState State.GetTagList
         , Store.getTagsForPackage = \pkgname -> queryState tagsState (State.TagsForPackage pkgname)
         , Store.getReviewTagsForPackage = \pkgname -> queryState tagsState (State.LookupReviewTags pkgname)
         , Store.getTagAlias = \tag -> queryState tagAlias (State.GetTagAlias tag)
         , Store.getPackagesForTag = \tag -> queryState tagsState (State.PackagesForTag tag)
-        , Store.getPackageTags = queryState tagsState State.GetPackageTags
+        , Store.getTagsForPackages = \pkgnames -> do
+            pkgTags <- State.packageTags <$> queryState tagsState State.GetPackageTags
+            pure $ Map.fromList
+              [ (pkgname, Map.findWithDefault Set.empty pkgname pkgTags) | pkgname <- pkgnames ]
         , Store.setPackageTags = \pkgname tags -> updateState tagsState (State.SetPackageTags pkgname tags)
         , Store.setTagPackages = \tag pkgs -> updateState tagsState (State.SetTagPackages tag pkgs)
         , Store.addTagAlias = \tag alias -> updateState tagAlias (State.AddTagAlias tag alias)

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

@@ -6,11 +6,11 @@ module Distribution.Server.Features.Tags.Store
   ) where
 
 import Distribution.Package (PackageName)
-import Distribution.Server.Features.Tags.State (PackageTags)
 import Distribution.Server.Features.Tags.Types (Tag)
 import Distribution.Server.Framework (AbstractStateComponent)
 
 import Control.Monad.Trans (MonadIO)
+import Data.Map (Map)
 import Data.Set (Set)
 
 data Backend = Backend {
@@ -19,12 +19,14 @@ data Backend = Backend {
   }
 
 data Store = Store {
-    getTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)]
+    -- | Every tag with its number of packages, in tag order.
+    getTagCounts :: forall m. MonadIO m => m [(Tag, Int)]
   , getTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag)
   , getReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag, Set Tag)
   , getTagAlias :: forall m. MonadIO m => Tag -> m Tag
   , getPackagesForTag :: forall m. MonadIO m => Tag -> m (Set PackageName)
-  , getPackageTags :: forall m. MonadIO m => m PackageTags
+    -- | The tags of each given package, including packages with none.
+  , getTagsForPackages :: forall m. MonadIO m => [PackageName] -> m (Map PackageName (Set Tag))
   , setPackageTags :: forall m. MonadIO m => PackageName -> Set Tag -> m ()
   , setTagPackages :: forall m. MonadIO m => Tag -> Set PackageName -> m ()
   , addTagAlias :: forall m. MonadIO m => Tag -> Tag -> m ()

src/Distribution/Server/Features/Votes.hs

@@ -14,8 +14,7 @@ import Distribution.Server.Features.Votes.Types (Score)
 import Distribution.Server.Features.Votes.Acid (acidStore)
 import qualified Distribution.Server.Features.Votes.Render as Render
 import Distribution.Server.Features.Votes.Store
-  ( votesScore
-  , Backend(..)
+  ( Backend(..)
   , Store(..) )
 
 import Distribution.Server.Framework
@@ -125,10 +124,10 @@ votesFeature  ServerEnv{..}
     servePackageVotesGet :: DynamicPath -> ServerPartE Response
     servePackageVotesGet _ = do
       cacheControlWithoutETag [Public, maxAgeMinutes 10]
-      votesMap <- getAllPackageVoteSets votesState
+      scores <- getAllPackageVoteScores votesState
       ok . toResponse $ objectL
-        [ (display pkgname, toJSON (votesScore pkgMap))
-        | (pkgname, pkgMap) <- Map.toList votesMap ]
+        [ (display pkgname, toJSON score)
+        | (pkgname, score) <- Map.toList scores ]
 
     -- Get the number of votes a package has. If the package
     -- has never been voted for, returns 0.