Commit 8abf69ea authored by Edward Z. Yang's avatar Edward Z. Yang Committed by Edward Z. Yang

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: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent e8e897e7
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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",
......
......@@ -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"
-*-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).
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment