Hook up `--index-state` to `install` flags in CLI

cabal-install/Distribution/Client/Config.hs

@@ -249,6 +249,7 @@ instance Semigroup SavedConfig where
         installUpgradeDeps           = combine installUpgradeDeps,
         installOnly                  = combine installOnly,
         installOnlyDeps              = combine installOnlyDeps,
+        installIndexState            = combine installIndexState,
         installRootCmd               = combine installRootCmd,
         installSummaryFile           = lastNonEmptyNL installSummaryFile,
         installLogFile               = combine installLogFile,

cabal-install/Distribution/Client/Install.hs

@@ -80,7 +80,7 @@ import Distribution.Client.HttpUtils
 import Distribution.Solver.Types.PackageFixedDeps
 import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
 import Distribution.Client.IndexUtils as IndexUtils
-         ( getSourcePackages, getInstalledPackages )
+         ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
 import Distribution.Client.InstallPlan (InstallPlan)
@@ -277,10 +277,13 @@ makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
                       -> IO InstallContext
 makeInstallContext verbosity
   (packageDBs, repoCtxt, comp, _, progdb,_,_,
-   globalFlags, _, configExFlags, _, _) mUserTargets = do
+   globalFlags, _, configExFlags, installFlags, _) mUserTargets = do
+
+    let idxState = fromFlagOrDefault IndexStateHead $
+                       installIndexState installFlags
 
     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
-    sourcePkgDb       <- getSourcePackages    verbosity repoCtxt
+    sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
     pkgConfigDb       <- readPkgConfigDb      verbosity progdb
 
     checkConfigExFlags verbosity installedPkgIndex

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -58,6 +58,8 @@ import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
 import Distribution.Client.Config
          ( loadConfig, defaultConfigFile )
+import Distribution.Client.IndexUtils.Timestamp
+         ( IndexState(..) )
 
 import Distribution.Solver.Types.SourcePackage
 import Distribution.Solver.Types.Settings
@@ -202,6 +204,7 @@ resolveSolverSettings ProjectConfig{
     solverSettingReorderGoals      = fromFlag projectConfigReorderGoals
     solverSettingCountConflicts    = fromFlag projectConfigCountConflicts
     solverSettingStrongFlags       = fromFlag projectConfigStrongFlags
+    solverSettingIndexState        = fromFlagOrDefault IndexStateHead projectConfigIndexState
   --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals
   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs
   --solverSettingReinstall         = fromFlag projectConfigReinstall

cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

@@ -302,6 +302,7 @@ convertLegacyAllPackageFlags globalFlags configFlags
     --installReinstall          = projectConfigReinstall,
     --installAvoidReinstalls    = projectConfigAvoidReinstalls,
     --installOverrideReinstall  = projectConfigOverrideReinstall,
+      installIndexState         = projectConfigIndexState,
       installMaxBackjumps       = projectConfigMaxBackjumps,
     --installUpgradeDeps        = projectConfigUpgradeDeps,
       installReorderGoals       = projectConfigReorderGoals,
@@ -505,6 +506,7 @@ convertToLegacySharedConfig
       installStrongFlags       = projectConfigStrongFlags,
       installOnly              = mempty,
       installOnlyDeps          = projectConfigOnlyDeps,
+      installIndexState        = projectConfigIndexState,
       installRootCmd           = mempty, --no longer supported
       installSummaryFile       = projectConfigSummaryFile,
       installLogFile           = projectConfigLogFile,
@@ -848,6 +850,7 @@ legacySharedConfigFieldDescrs =
       , "one-shot", "jobs", "keep-going", "offline"
         -- solver flags:
       , "max-backjumps", "reorder-goals", "count-conflicts", "strong-flags"
+      , "index-state"
       ]
   . commandOptionsToFields
   ) (installOptions ParseArgs)

cabal-install/Distribution/Client/ProjectConfig/Types.hs

@@ -29,6 +29,9 @@ import Distribution.Client.Targets
 import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
 
+import Distribution.Client.IndexUtils.Timestamp
+         ( IndexState )
+
 import Distribution.Solver.Types.Settings
 import Distribution.Solver.Types.ConstraintSource
 
@@ -164,6 +167,7 @@ data ProjectConfigShared
        -- configuration used both by the solver and other phases
        projectConfigRemoteRepos       :: NubList RemoteRepo,     -- ^ Available Hackage servers.
        projectConfigLocalRepos        :: NubList FilePath,
+       projectConfigIndexState        :: Flag IndexState,
 
        -- solver configuration
        projectConfigConstraints       :: [(UserConstraint, ConstraintSource)],
@@ -347,7 +351,8 @@ data SolverSettings
        solverSettingMaxBackjumps      :: Maybe Int,
        solverSettingReorderGoals      :: ReorderGoals,
        solverSettingCountConflicts    :: CountConflicts,
-       solverSettingStrongFlags       :: StrongFlags
+       solverSettingStrongFlags       :: StrongFlags,
+       solverSettingIndexState        :: IndexState
        -- Things that only make sense for manual mode, not --local mode
        -- too much control!
      --solverSettingIndependentGoals  :: Bool,

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -480,8 +480,9 @@ rebuildInstallPlan verbosity
           installedPkgIndex <- getInstalledPackages verbosity
                                                     compiler progdb platform
                                                     corePackageDbs
-          sourcePkgDb       <- getSourcePackages    verbosity withRepoCtx
-          pkgConfigDB       <- getPkgConfigDb      verbosity progdb
+          sourcePkgDb       <- getSourcePackages verbosity withRepoCtx
+                                 (solverSettingIndexState solverSettings)
+          pkgConfigDB       <- getPkgConfigDb verbosity progdb
 
           --TODO: [code cleanup] it'd be better if the Compiler contained the
           -- ConfiguredPrograms that it needs, rather than relying on the progdb
@@ -688,12 +689,13 @@ getExecutableDBContents storeDirectory = do
     valid _ = True
 
 getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-                  -> Rebuild SourcePackageDb
-getSourcePackages verbosity withRepoCtx = do
+                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb
+getSourcePackages verbosity withRepoCtx idxState = do
     (sourcePkgDb, repos) <-
       liftIO $
         withRepoCtx $ \repoctx -> do
-          sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoctx
+          sourcePkgDb <- IndexUtils.getSourcePackagesAtIndexState verbosity
+                                                                  repoctx idxState
           return (sourcePkgDb, repoContextRepos repoctx)
 
     monitorFiles . map monitorFile

cabal-install/Distribution/Client/Setup.hs

@@ -61,6 +61,10 @@ import Distribution.Client.BuildReports.Types
          ( ReportLevel(..) )
 import Distribution.Client.Dependency.Types
          ( PreSolver(..) )
+
+import Distribution.Client.IndexUtils.Timestamp
+         ( IndexState )
+
 import qualified Distribution.Client.Init.Types as IT
          ( InitFlags(..), PackageType(..) )
 import Distribution.Client.Targets
@@ -1219,6 +1223,7 @@ data InstallFlags = InstallFlags {
     installUpgradeDeps      :: Flag Bool,
     installOnly             :: Flag Bool,
     installOnlyDeps         :: Flag Bool,
+    installIndexState       :: Flag IndexState,
     installRootCmd          :: Flag String,
     installSummaryFile      :: NubList PathTemplate,
     installLogFile          :: Flag PathTemplate,
@@ -1252,6 +1257,7 @@ defaultInstallFlags = InstallFlags {
     installUpgradeDeps     = Flag False,
     installOnly            = Flag False,
     installOnlyDeps        = Flag False,
+    installIndexState      = mempty,
     installRootCmd         = mempty,
     installSummaryFile     = mempty,
     installLogFile         = mempty,
@@ -1424,6 +1430,18 @@ installOptions showOrParseArgs =
           installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
           (yesNoOpt showOrParseArgs)
 
+      , option [] ["index-state"]
+          ("Use source package index state as it existed at a previous time. " ++
+           "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
+           "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")
+          installIndexState (\v flags -> flags { installIndexState = v })
+          (reqArg "STATE" (readP_to_E (const $ "index-state must be a  " ++
+                                       "unix-timestamps (e.g. '@1474732068'), " ++
+                                       "a ISO8601 UTC timestamp " ++
+                                       "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
+                                      (toFlag `fmap` parse))
+                          (flagToList . fmap display))
+
       , option [] ["root-cmd"]
           "(No longer supported, do not use.)"
           installRootCmd (\v flags -> flags { installRootCmd = v })

cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs

@@ -30,6 +30,8 @@ import Distribution.Simple.InstallDirs
 
 import Distribution.Utils.NubList
 
+import Distribution.Client.IndexUtils.Timestamp
+
 import Test.QuickCheck
 
 
@@ -172,3 +174,10 @@ instance Arbitrary a => Arbitrary (NoShrink a) where
     arbitrary = NoShrink <$> arbitrary
     shrink _  = []
 
+instance Arbitrary Timestamp where
+    arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary
+
+instance Arbitrary IndexState where
+    arbitrary = frequency [ (1, pure IndexStateHead)
+                          , (50, IndexStateTime <$> arbitrary)
+                          ]

cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs

@@ -344,6 +344,7 @@ instance Arbitrary ProjectConfigShared where
         <*> arbitrary
         <*> arbitrary
         <*> (toNubList <$> listOf arbitraryShortToken)
+        <*> arbitrary
         <*> arbitraryConstraints
         <*> shortListOf 2 arbitrary
         <*> arbitrary <*> arbitrary
@@ -358,19 +359,21 @@ instance Arbitrary ProjectConfigShared where
     shrink (ProjectConfigShared
               x00 x01 x02 x03 x04
               x05 x06 x07 x08 x09
-              x10 x11 x12 x13 x14 x15) =
+              x10 x11 x12 x13 x14
+              x15 x16) =
       [ ProjectConfigShared
           x00' (fmap getNonEmpty x01') (fmap getNonEmpty x02') x03' x04'
-          x05' (postShrink_Constraints x06') x07' x08' x09'
-          x10' x11' x12' x13' x14' x15'
+          x05' x06' (postShrink_Constraints x07') x08' x09'
+          x10' x11' x12' x13' x14' x15' x16'
       | ((x00', x01', x02', x03', x04'),
          (x05', x06', x07', x08', x09'),
          (x10', x11', x12', x13', x14'),
-          x15')
+         (x15', x16'))
           <- shrink
                ((x00, fmap NonEmpty x01, fmap NonEmpty x02, x03, x04),
-                (x05, preShrink_Constraints x06, x07, x08, x09),
-                (x10, x11, x12, x13, x14), x15)
+                (x05, x06, preShrink_Constraints x07, x08, x09),
+                (x10, x11, x12, x13, x14),
+                (x15, x16))
       ]
       where
         preShrink_Constraints  = map fst