Support cabal update --index-state.

The strategy is to save an 01-index.timestamp file that remembers
what --index-state the user requested during cabal update.
Subsequently, we use that index state if no more precise
index state was specified (via the flag or a project config.)
Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

cabal-install/Distribution/Client/Get.hs

@@ -23,7 +23,7 @@ import Distribution.Client.Compat.Prelude hiding (get)
 import Distribution.Package
          ( PackageId, packageId, packageName )
 import Distribution.Simple.Setup
-         ( Flag(..), fromFlag, fromFlagOrDefault )
+         ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
 import Distribution.Simple.Utils
          ( notice, die', info, rawSystemExitCode, writeFileAtomic )
 import Distribution.Verbosity
@@ -39,7 +39,7 @@ import Distribution.Client.Dependency
 import Distribution.Client.FetchUtils
 import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
 import Distribution.Client.IndexUtils as IndexUtils
-        ( getSourcePackagesAtIndexState, IndexState(..) )
+        ( getSourcePackagesAtIndexState )
 import Distribution.Client.Compat.Process
         ( readProcessWithExitCode )
 import Distribution.Compat.Exception
@@ -82,8 +82,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do
   unless useFork $
     mapM_ (checkTarget verbosity) userTargets
 
-  let idxState = fromFlagOrDefault IndexStateHead $
-                       getIndexState getFlags
+  let idxState = flagToMaybe $ getIndexState getFlags
 
   sourcePkgDb <- getSourcePackagesAtIndexState verbosity repoCtxt idxState
 

cabal-install/Distribution/Client/IndexUtils.hs

@@ -32,6 +32,8 @@ module Distribution.Client.IndexUtils (
   parsePackageIndex,
   updateRepoIndexCache,
   updatePackageIndexCacheFile,
+  writeIndexTimestamp,
+  currentIndexTimestamp,
   readCacheStrict, -- only used by soon-to-be-obsolete sandbox code
 
   BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType
@@ -195,7 +197,7 @@ 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 IndexStateHead
+    getSourcePackagesAtIndexState verbosity repoCtxt Nothing
 
 -- | Variant of 'getSourcePackages' which allows getting the source
 -- packages at a particular 'IndexState'.
@@ -206,7 +208,7 @@ getSourcePackages verbosity repoCtxt =
 -- TODO: Enhance to allow specifying per-repo 'IndexState's and also
 -- report back per-repo 'IndexStateInfo's (in order for @new-freeze@
 -- to access it)
-getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> IndexState
+getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState
                            -> IO SourcePackageDb
 getSourcePackagesAtIndexState verbosity repoCtxt _
   | null (repoContextRepos repoCtxt) = do
@@ -219,22 +221,36 @@ getSourcePackagesAtIndexState verbosity repoCtxt _
         packageIndex       = mempty,
         packagePreferences = mempty
       }
-getSourcePackagesAtIndexState verbosity repoCtxt idxState = do
-  case idxState of
-      IndexStateHead      -> info verbosity "Reading available packages..."
-      IndexStateTime time ->
-          info verbosity ("Reading available packages (for index-state as of "
-                          ++ display time ++ ")...")
+getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do
+  let describeState IndexStateHead        = "most recent state"
+      describeState (IndexStateTime time) = "historical state as of " ++ display time
 
   pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do
       let rname = maybe "" remoteRepoName $ maybeRepoRemote r
+      info verbosity ("Reading available packages of " ++ rname ++ "...")
+
+      idxState <- case mb_idxState of
+        Just idxState -> do
+          info verbosity $ "Using " ++ describeState idxState ++
+            " as explicitly requested (via command line / project configuration)"
+          return idxState
+        Nothing -> do
+          mb_idxState' <- readIndexTimestamp (RepoIndex repoCtxt r)
+          case mb_idxState' of
+            Nothing -> do
+              info verbosity "Using most recent state (could not read timestamp file)"
+              return IndexStateHead
+            Just idxState -> do
+              info verbosity $ "Using " ++ describeState idxState ++
+                " specified from most recent cabal update"
+              return idxState
+
       unless (idxState == IndexStateHead) $
           case r of
             RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")
             RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')")
             RepoSecure {} -> pure ()
 
-
       let idxState' = case r of
             RepoSecure {} -> idxState
             _             -> IndexStateHead
@@ -342,7 +358,9 @@ getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"
 --
 getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
 getSourcePackagesMonitorFiles repos =
-    [ indexBaseName repo <.> "cache" | repo <- repos ]
+    concat [ [ indexBaseName repo <.> "cache"
+             , indexBaseName repo <.> "timestamp" ]
+           | repo <- repos ]
 
 -- | It is not necessary to call this, as the cache will be updated when the
 -- index is read normally. However you can do the work earlier if you like.
@@ -544,6 +562,10 @@ cacheFile :: Index -> FilePath
 cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"
 cacheFile (SandboxIndex index)   = index `replaceExtension` "cache"
 
+timestampFile :: Index -> FilePath
+timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"
+timestampFile (SandboxIndex index)   = index `replaceExtension` "timestamp"
+
 -- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
 is01Index :: Index -> Bool
 is01Index (RepoIndex _ repo) = case repo of
@@ -769,6 +791,31 @@ writeIndexCache index cache
   | is01Index index = encodeFile (cacheFile index) cache
   | otherwise       = writeFile (cacheFile index) (show00IndexCache cache)
 
+-- | Write the 'IndexState' to the filesystem
+writeIndexTimestamp :: Index -> IndexState -> IO ()
+writeIndexTimestamp index st
+  = writeFile (timestampFile index) (display st)
+
+-- | Read out the "current" index timestamp, i.e., what
+-- timestamp you would use to revert to this version
+currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp
+currentIndexTimestamp verbosity repoCtxt r = do
+    mb_is <- readIndexTimestamp (RepoIndex repoCtxt r)
+    case mb_is of
+      Just (IndexStateTime ts) -> return ts
+      _ -> do
+        (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead
+        return (isiHeadTime isi)
+
+-- | Read the 'IndexState' from the filesystem
+readIndexTimestamp :: Index -> IO (Maybe IndexState)
+readIndexTimestamp index
+  = fmap simpleParse (readFile (timestampFile index))
+        `catchIO` \e ->
+            if isDoesNotExistError e
+                then return Nothing
+                else ioError e
+
 -- | Optimise sharing of equal values inside 'Cache'
 --
 -- c.f. https://en.wikipedia.org/wiki/Hash_consing

cabal-install/Distribution/Client/Install.hs

@@ -72,7 +72,7 @@ import Distribution.Client.HttpUtils
 import Distribution.Solver.Types.PackageFixedDeps
 import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
 import Distribution.Client.IndexUtils as IndexUtils
-         ( getSourcePackagesAtIndexState, IndexState(..), getInstalledPackages )
+         ( getSourcePackagesAtIndexState, getInstalledPackages )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
 import Distribution.Client.InstallPlan (InstallPlan)
@@ -277,8 +277,7 @@ makeInstallContext verbosity
   (packageDBs, repoCtxt, comp, _, progdb,_,_,
    globalFlags, _, configExFlags, installFlags, _) mUserTargets = do
 
-    let idxState = fromFlagOrDefault IndexStateHead $
-                       installIndexState installFlags
+    let idxState = flagToMaybe (installIndexState installFlags)
 
     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
     sourcePkgDb       <- getSourcePackagesAtIndexState verbosity repoCtxt idxState

cabal-install/Distribution/Client/ProjectConfig.hs

@@ -63,8 +63,6 @@ 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
@@ -209,7 +207,7 @@ resolveSolverSettings ProjectConfig{
     solverSettingCountConflicts    = fromFlag projectConfigCountConflicts
     solverSettingStrongFlags       = fromFlag projectConfigStrongFlags
     solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls
-    solverSettingIndexState        = fromFlagOrDefault IndexStateHead projectConfigIndexState
+    solverSettingIndexState        = flagToMaybe projectConfigIndexState
   --solverSettingIndependentGoals  = fromFlag projectConfigIndependentGoals
   --solverSettingShadowPkgs        = fromFlag projectConfigShadowPkgs
   --solverSettingReinstall         = fromFlag projectConfigReinstall

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

@@ -357,7 +357,7 @@ data SolverSettings
        solverSettingCountConflicts    :: CountConflicts,
        solverSettingStrongFlags       :: StrongFlags,
        solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,
-       solverSettingIndexState        :: IndexState
+       solverSettingIndexState        :: Maybe IndexState
        -- Things that only make sense for manual mode, not --local mode
        -- too much control!
      --solverSettingIndependentGoals  :: IndependentGoals,

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -714,7 +714,7 @@ getInstalledStorePackages storeDirectory = do
     valid _            = True
 
 getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-                  -> IndexUtils.IndexState -> Rebuild SourcePackageDb
+                  -> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb
 getSourcePackages verbosity withRepoCtx idxState = do
     (sourcePkgDb, repos) <-
       liftIO $
@@ -723,9 +723,9 @@ getSourcePackages verbosity withRepoCtx idxState = do
                                                                   repoctx idxState
           return (sourcePkgDb, repoContextRepos repoctx)
 
-    monitorFiles . map monitorFile
-                 . IndexUtils.getSourcePackagesMonitorFiles
-                 $ repos
+    mapM_ needIfExists
+        . IndexUtils.getSourcePackagesMonitorFiles
+        $ repos
     return sourcePkgDb
 
 

cabal-install/Distribution/Client/Setup.hs

@@ -26,7 +26,7 @@ module Distribution.Client.Setup
     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
     , defaultSolver, defaultMaxBackjumps
     , listCommand, ListFlags(..)
-    , updateCommand
+    , updateCommand, UpdateFlags(..)
     , upgradeCommand
     , uninstallCommand
     , infoCommand, InfoFlags(..)
@@ -66,7 +66,7 @@ import Distribution.Client.BuildReports.Types
 import Distribution.Client.Dependency.Types
          ( PreSolver(..) )
 import Distribution.Client.IndexUtils.Timestamp
-         ( IndexState )
+         ( IndexState(..) )
 import qualified Distribution.Client.Init.Types as IT
          ( InitFlags(..), PackageType(..) )
 import Distribution.Client.Targets
@@ -972,10 +972,23 @@ outdatedCommand = CommandUI {
       (Parse.sepBy1 parse (Parse.char ','))
 
 -- ------------------------------------------------------------
--- * Other commands
+-- * Update command
 -- ------------------------------------------------------------
 
-updateCommand  :: CommandUI (Flag Verbosity)
+data UpdateFlags
+    = UpdateFlags {
+        updateVerbosity  :: Flag Verbosity,
+        updateIndexState :: Flag IndexState
+    } deriving Generic
+
+defaultUpdateFlags :: UpdateFlags
+defaultUpdateFlags
+    = UpdateFlags {
+        updateVerbosity  = toFlag normal,
+        updateIndexState = toFlag IndexStateHead
+    }
+
+updateCommand  :: CommandUI UpdateFlags
 updateCommand = CommandUI {
     commandName         = "update",
     commandSynopsis     = "Updates list of known packages.",
@@ -986,10 +999,27 @@ updateCommand = CommandUI {
                                ,"remote-repo-cache"
                                ,"local-repo"],
     commandUsage        = usageFlags "update",
-    commandDefaultFlags = toFlag normal,
-    commandOptions      = \_ -> [optionVerbosity id const]
+    commandDefaultFlags = defaultUpdateFlags,
+    commandOptions      = \_ -> [
+        optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }),
+        option [] ["index-state"]
+          ("Update the source package index to its 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').")
+          updateIndexState (\v flags -> flags { updateIndexState = 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))
+    ]
   }
 
+-- ------------------------------------------------------------
+-- * Other commands
+-- ------------------------------------------------------------
+
 upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
 upgradeCommand = configureCommand {
     commandName         = "upgrade",

cabal-install/Distribution/Client/Update.hs

@@ -15,6 +15,8 @@ module Distribution.Client.Update
     ( update
     ) where
 
+import Distribution.Simple.Setup
+         ( fromFlag )
 import Distribution.Client.Types
          ( Repo(..), RemoteRepo(..), maybeRepoRemote )
 import Distribution.Client.HttpUtils
@@ -22,16 +24,19 @@ import Distribution.Client.HttpUtils
 import Distribution.Client.FetchUtils
          ( downloadIndex )
 import Distribution.Client.IndexUtils
-         ( updateRepoIndexCache, Index(..) )
+         ( updateRepoIndexCache, Index(..), writeIndexTimestamp
+         , currentIndexTimestamp )
 import Distribution.Client.JobControl
          ( newParallelJobControl, spawnJob, collectJob )
 import Distribution.Client.Setup
-         ( RepoContext(..) )
+         ( RepoContext(..), UpdateFlags(..) )
+import Distribution.Text
+         ( display )
 import Distribution.Verbosity
          ( Verbosity )
 
 import Distribution.Simple.Utils
-         ( writeFileAtomic, warn, notice )
+         ( writeFileAtomic, warn, notice, noticeNoWrap )
 
 import qualified Data.ByteString.Lazy       as BS
 import Distribution.Client.GZipUtils (maybeDecompress)
@@ -42,11 +47,11 @@ import Data.Time (getCurrentTime)
 import qualified Hackage.Security.Client as Sec
 
 -- | 'update' downloads the package list from all known servers
-update :: Verbosity -> RepoContext -> IO ()
-update verbosity repoCtxt | null (repoContextRepos repoCtxt) = do
+update :: Verbosity -> UpdateFlags -> RepoContext -> IO ()
+update verbosity _ repoCtxt | null (repoContextRepos repoCtxt) = do
   warn verbosity $ "No remote package servers have been specified. Usually "
                 ++ "you would have one specified in the config file."
-update verbosity repoCtxt = do
+update verbosity updateFlags repoCtxt = do
   let repos       = repoContextRepos repoCtxt
       remoteRepos = catMaybes (map maybeRepoRemote repos)
   case remoteRepos of
@@ -58,11 +63,11 @@ update verbosity repoCtxt = do
             $ "Downloading the latest package lists from: "
             : map (("- " ++) . remoteRepoName) remoteRepos
   jobCtrl <- newParallelJobControl (length repos)
-  mapM_ (spawnJob jobCtrl . updateRepo verbosity repoCtxt) repos
+  mapM_ (spawnJob jobCtrl . updateRepo verbosity updateFlags repoCtxt) repos
   mapM_ (\_ -> collectJob jobCtrl) repos
 
-updateRepo :: Verbosity -> RepoContext -> Repo -> IO ()
-updateRepo verbosity repoCtxt repo = do
+updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> Repo -> IO ()
+updateRepo verbosity updateFlags repoCtxt repo = do
   transport <- repoContextGetTransport repoCtxt
   case repo of
     RepoLocal{..} -> return ()
@@ -75,6 +80,11 @@ updateRepo verbosity repoCtxt repo = do
                                                   =<< BS.readFile indexPath
           updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
     RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
+      let index = RepoIndex repoCtxt repo
+      current_ts <- currentIndexTimestamp verbosity repoCtxt repo
+      -- NB: always update the timestamp, even if we didn't actually
+      -- download anything
+      writeIndexTimestamp index (fromFlag (updateIndexState updateFlags))
       ce <- if repoContextIgnoreExpiry repoCtxt
               then Just `fmap` getCurrentTime
               else return Nothing
@@ -85,4 +95,10 @@ updateRepo verbosity repoCtxt repo = do
         Sec.NoUpdates  ->
           return ()
         Sec.HasUpdates ->
-          updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
+          updateRepoIndexCache verbosity index
+      -- TODO: This will print multiple times if there are multiple
+      -- repositories: main problem is we don't have a way of updating
+      -- a specific repo.  Once we implement that, update this.
+      noticeNoWrap verbosity $
+        "To revert to previous state run:\n" ++
+        "    cabal update --index-state='" ++ display current_ts ++ "'\n"

cabal-install/changelog

 -*-change-log-*-
 
+2.2.0.0 (current development version)
+	* 'cabal update' supporst '--index-state' which can be used to
+	roll back the index to an earlier state.
+
 2.0.0.0 (current development version)
 	* Removed the '--root-cmd' parameter of the 'install' command
 	(#3356).

cabal-install/main/Main.hs

@@ -32,7 +32,7 @@ import Distribution.Client.Setup
          , GetFlags(..), getCommand, unpackCommand
          , checkCommand
          , formatCommand
-         , updateCommand
+         , UpdateFlags(..), updateCommand
          , ListFlags(..), listCommand
          , InfoFlags(..), infoCommand
          , UploadFlags(..), uploadCommand
@@ -816,16 +816,16 @@ infoAction infoFlags extraArgs globalFlags = do
        infoFlags
        targets
 
-updateAction :: Flag Verbosity -> [String] -> Action
-updateAction verbosityFlag extraArgs globalFlags = do
-  let verbosity = fromFlag verbosityFlag
+updateAction :: UpdateFlags -> [String] -> Action
+updateAction updateFlags extraArgs globalFlags = do
+  let verbosity = fromFlag (updateVerbosity updateFlags)
   unless (null extraArgs) $
     die' verbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
   (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity
                            (globalFlags { globalRequireSandbox = Flag False })
   let globalFlags' = savedGlobalFlags config `mappend` globalFlags
   withRepoContext verbosity globalFlags' $ \repoContext ->
-    update verbosity repoContext
+    update verbosity updateFlags repoContext
 
 upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
               -> [String] -> Action