Make v2-freeze store index-state

cabal-install/Distribution/Client/CmdFreeze.hs

@@ -12,6 +12,7 @@ import Distribution.Client.ProjectPlanning
 import Distribution.Client.ProjectConfig
          ( ProjectConfig(..), ProjectConfigShared(..)
          , writeProjectLocalFreezeConfig )
+import Distribution.Client.IndexUtils (TotalIndexState)
 import Distribution.Client.Targets
          ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
 import Distribution.Solver.Types.PackageConstraint
@@ -34,12 +35,12 @@ import Distribution.Client.Setup
          ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
 import Distribution.Simple.Setup
          ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
+import Distribution.Simple.Flag (Flag (..))
 import Distribution.Simple.Utils
          ( die', notice, wrapText )
 import Distribution.Verbosity
          ( normal )
 
-import Data.Monoid as Monoid
 import qualified Data.Map as Map
 import Data.Map (Map)
 import Control.Monad (unless)
@@ -119,13 +120,13 @@ freezeAction ( configFlags, configExFlags, installFlags
       localPackages
     } <- establishProjectBaseContext verbosity cliConfig OtherCommand
 
-    (_, elaboratedPlan, _) <-
+    (_, elaboratedPlan, _, totalIndexState) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig
                          localPackages
 
-    let freezeConfig = projectFreezeConfig elaboratedPlan
+    let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState
     writeProjectLocalFreezeConfig distDirLayout freezeConfig
     notice verbosity $
       "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
@@ -143,13 +144,13 @@ freezeAction ( configFlags, configExFlags, installFlags
 -- | Given the install plan, produce a config value with constraints that
 -- freezes the versions of packages used in the plan.
 --
-projectFreezeConfig :: ElaboratedInstallPlan -> ProjectConfig
-projectFreezeConfig elaboratedPlan =
-    Monoid.mempty {
-      projectConfigShared = Monoid.mempty {
-        projectConfigConstraints =
+projectFreezeConfig :: ElaboratedInstallPlan -> TotalIndexState -> ProjectConfig
+projectFreezeConfig elaboratedPlan totalIndexState = mempty
+    { projectConfigShared = mempty
+        { projectConfigConstraints =
           concat (Map.elems (projectFreezeConstraints elaboratedPlan))
-      }
+        , projectConfigIndexState = Flag totalIndexState
+        }
     }
 
 -- | Given the install plan, produce solver constraints that will ensure the

cabal-install/Distribution/Client/Get.hs

@@ -89,7 +89,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
   let idxState :: Maybe TotalIndexState
       idxState = flagToMaybe $ getIndexState getFlags
 
-  sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
+  (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
 
   pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
                    (fromFlag $ globalWorldFile globalFlags)

cabal-install/Distribution/Client/IndexUtils.hs

@@ -199,44 +199,46 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
 -- This is a higher level wrapper used internally in cabal-install.
 getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
 getSourcePackages verbosity repoCtxt =
-    getSourcePackagesAtIndexState verbosity repoCtxt Nothing
+    fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing
 
 -- | Variant of 'getSourcePackages' which allows getting the source
 -- packages at a particular 'IndexState'.
 --
 -- Current choices are either the latest (aka HEAD), or the index as
 -- it was at a particular time.
 --
--- TODO: Enhance to allow specifying per-repo 'IndexState's and also
--- report back per-repo 'IndexStateInfo's (in order for @v2-freeze@
--- to access it)
+-- Returns also the total index where repositories'
+-- RepoIndexState's are not HEAD. This is used in v2-freeze.
+--
 getSourcePackagesAtIndexState
     :: Verbosity
     -> RepoContext
     -> Maybe TotalIndexState
-    -> IO SourcePackageDb -- TODO: return TotalIndexState
+    -> IO (SourcePackageDb, TotalIndexState)
 getSourcePackagesAtIndexState verbosity repoCtxt _
   | null (repoContextRepos repoCtxt) = do
       -- In the test suite, we routinely don't have any remote package
       -- servers, so don't bleat about it
       warn (verboseUnmarkOutput verbosity) $
         "No remote package servers have been specified. Usually " ++
         "you would have one specified in the config file."
-      return SourcePackageDb {
+      return (SourcePackageDb {
         packageIndex       = mempty,
         packagePreferences = mempty
-      }
+      }, headTotalIndexState)
 getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
   let describeState IndexStateHead        = "most recent state"
       describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
 
   pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
-      let rname :: RepoName
-          rname =  case r of
-              RepoRemote remote _      -> remoteRepoName remote
-              RepoSecure remote _      -> remoteRepoName remote
-              RepoLocalNoIndex local _ -> localRepoName local
-              RepoLocal _              -> RepoName "__local-repository" -- TODO...
+      let mrname :: Maybe RepoName
+          mrname = case r of
+              RepoRemote remote _      -> Just $ remoteRepoName remote
+              RepoSecure remote _      -> Just $ remoteRepoName remote
+              RepoLocalNoIndex local _ -> Just $ localRepoName local
+              RepoLocal _              -> Nothing
+
+      let rname = fromMaybe (RepoName "__local-repository") mrname
 
       info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
 
@@ -291,17 +293,40 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
                               prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
                               prettyShow (isiHeadTime isi) ++ ")")
 
-      pure (pis,deps)
+      pure RepoData
+          { rdIndexStates = maybe [] (\n -> [(n, isiMaxTime isi)]) mrname
+          , rdIndex       = pis
+          , rdPreferences = deps
+          }
 
-  let (pkgs, prefs) = mconcat pkgss
+  let RepoData indexStates pkgs prefs = mconcat pkgss
       prefs' = Map.fromListWith intersectVersionRanges
                  [ (name, range) | Dependency name range _ <- prefs ]
+      totalIndexState = foldl'
+          (\acc (rn, ts) -> insertIndexState rn (IndexStateTime ts) acc)
+          headTotalIndexState
+          indexStates
   _ <- evaluate pkgs
   _ <- evaluate prefs'
-  return SourcePackageDb {
+  _ <- evaluate totalIndexState
+  return (SourcePackageDb {
     packageIndex       = pkgs,
     packagePreferences = prefs'
-  }
+  }, totalIndexState)
+
+-- auxiliary data used in getSourcePackagesAtIndexState
+data RepoData = RepoData
+    { rdIndexStates :: [(RepoName, Timestamp)]
+    , rdIndex       :: PackageIndex UnresolvedSourcePackage
+    , rdPreferences :: [Dependency]
+    }
+
+instance Semigroup RepoData where
+    RepoData x y z <> RepoData u v w = RepoData (x <> u) (y <> v) (z <> w)
+
+instance Monoid RepoData where
+    mempty  = RepoData mempty mempty mempty
+    mappend = (<>)
 
 readCacheStrict :: NFData pkg => Verbosity -> Index -> (PackageEntry -> pkg) -> IO ([pkg], [Dependency])
 readCacheStrict verbosity index mkPkg = do

cabal-install/Distribution/Client/IndexUtils/IndexState.hs

@@ -14,6 +14,7 @@ module Distribution.Client.IndexUtils.IndexState (
     headTotalIndexState,
     makeTotalIndexState,
     lookupIndexState,
+    insertIndexState,
 ) where
 
 import Distribution.Client.Compat.Prelude
@@ -106,6 +107,12 @@ makeTotalIndexState def m = normalise (TIS def m)
 lookupIndexState :: RepoName -> TotalIndexState -> RepoIndexState
 lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m
 
+-- | Insert a 'RepoIndexState' to 'TotalIndexState'.
+insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
+insertIndexState rn idx (TIS def m)
+    | idx == def = TIS def (Map.delete rn m)
+    | otherwise  = TIS def (Map.insert rn idx m)
+
 -------------------------------------------------------------------------------
 -- Repository index state
 -------------------------------------------------------------------------------

cabal-install/Distribution/Client/Install.hs

@@ -289,7 +289,7 @@ makeInstallContext verbosity
     let idxState = flagToMaybe (installIndexState installFlags)
 
     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
-    sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
+    (sourcePkgDb, _)  <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
     pkgConfigDb       <- readPkgConfigDb      verbosity progdb
 
     checkConfigExFlags verbosity installedPkgIndex

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -292,7 +292,7 @@ withInstallPlan
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
-    (elaboratedPlan, _, elaboratedShared) <-
+    (elaboratedPlan, _, elaboratedShared, _) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig
@@ -317,7 +317,7 @@ runProjectPreBuildPhase
     -- everything in the project. This is independent of any specific targets
     -- the user has asked for.
     --
-    (elaboratedPlan, _, elaboratedShared) <-
+    (elaboratedPlan, _, elaboratedShared, _) <-
       rebuildInstallPlan verbosity
                          distDirLayout cabalDirLayout
                          projectConfig

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -396,7 +396,8 @@ rebuildInstallPlan :: Verbosity
                    -> [PackageSpecifier UnresolvedSourcePackage]
                    -> IO ( ElaboratedInstallPlan  -- with store packages
                          , ElaboratedInstallPlan  -- with source packages
-                         , ElaboratedSharedConfig )
+                         , ElaboratedSharedConfig
+                         , IndexUtils.TotalIndexState )
                       -- ^ @(improvedPlan, elaboratedPlan, _, _)@
 rebuildInstallPlan verbosity
                    distDirLayout@DistDirLayout {
@@ -417,14 +418,14 @@ rebuildInstallPlan verbosity
                    (projectConfigMonitored, localPackages, progsearchpath) $ do
 
       -- And so is the elaborated plan that the improved plan based on
-      (elaboratedPlan, elaboratedShared) <-
+      (elaboratedPlan, elaboratedShared, totalIndexState) <-
         rerunIfChanged verbosity fileMonitorElaboratedPlan
                        (projectConfigMonitored, localPackages,
                         progsearchpath) $ do
 
           compilerEtc   <- phaseConfigureCompiler projectConfig
           _             <- phaseConfigurePrograms projectConfig compilerEtc
-          (solverPlan, pkgConfigDB)
+          (solverPlan, pkgConfigDB, totalIndexState)
                         <- phaseRunSolver         projectConfig
                                                   compilerEtc
                                                   localPackages
@@ -435,14 +436,14 @@ rebuildInstallPlan verbosity
                                                    localPackages
 
           phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
-          return (elaboratedPlan, elaboratedShared)
+          return (elaboratedPlan, elaboratedShared, totalIndexState)
 
       -- The improved plan changes each time we install something, whereas
       -- the underlying elaborated plan only changes when input config
       -- changes, so it's worth caching them separately.
       improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
 
-      return (improvedPlan, elaboratedPlan, elaboratedShared)
+      return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState)
 
   where
     fileMonitorCompiler       = newFileMonitorInCacheDir "compiler"
@@ -543,10 +544,11 @@ rebuildInstallPlan verbosity
     -- Run the solver to get the initial install plan.
     -- This is expensive so we cache it independently.
     --
-    phaseRunSolver :: ProjectConfig
-                   -> (Compiler, Platform, ProgramDb)
-                   -> [PackageSpecifier UnresolvedSourcePackage]
-                   -> Rebuild (SolverInstallPlan, PkgConfigDb)
+    phaseRunSolver
+        :: ProjectConfig
+        -> (Compiler, Platform, ProgramDb)
+        -> [PackageSpecifier UnresolvedSourcePackage]
+        -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState)
     phaseRunSolver projectConfig@ProjectConfig {
                      projectConfigShared,
                      projectConfigBuildOnly
@@ -561,7 +563,7 @@ rebuildInstallPlan verbosity
           installedPkgIndex <- getInstalledPackages verbosity
                                                     compiler progdb platform
                                                     corePackageDbs
-          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx
+          (sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx
                                  (solverSettingIndexState solverSettings)
           pkgConfigDB       <- getPkgConfigDb verbosity progdb
 
@@ -580,7 +582,7 @@ rebuildInstallPlan verbosity
               planPackages verbosity compiler platform solver solverSettings
                            installedPkgIndex sourcePkgDb pkgConfigDB
                            localPackages localPackagesEnabledStanzas
-            return (plan, pkgConfigDB)
+            return (plan, pkgConfigDB, tis)
       where
         corePackageDbs = [GlobalPackageDB]
         withRepoCtx    = projectConfigWithSolverRepoContext verbosity
@@ -757,20 +759,23 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
                                  packagedb progdb
 -}
 
-getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-                  -> Maybe IndexUtils.TotalIndexState -> Rebuild SourcePackageDb
+getSourcePackages
+    :: Verbosity
+    -> (forall a. (RepoContext -> IO a) -> IO a)
+    -> Maybe IndexUtils.TotalIndexState
+    -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState)
 getSourcePackages verbosity withRepoCtx idxState = do
-    (sourcePkgDb, repos) <-
+    (sourcePkgDbWithTIS, repos) <-
       liftIO $
         withRepoCtx $ \repoctx -> do
-          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
+          sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity
                                                                   repoctx idxState
-          return (sourcePkgDb, repoContextRepos repoctx)
+          return (sourcePkgDbWithTIS, repoContextRepos repoctx)
 
     mapM_ needIfExists
         . IndexUtils.getSourcePackagesMonitorFiles
         $ repos
-    return sourcePkgDb
+    return sourcePkgDbWithTIS
 
 
 getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb