diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index fcdd371cc14..ed24965b46b 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/CmdUpdate.hs b/cabal-install/Distribution/Client/CmdUpdate.hs index c830d3bb58a..c09560a9ce9 100644 --- a/cabal-install/Distribution/Client/CmdUpdate.hs +++ b/cabal-install/Distribution/Client/CmdUpdate.hs @@ -102,7 +102,7 @@ updateCommand = Client.installCommand { data UpdateRequest = UpdateRequest { _updateRequestRepoName :: RepoName - , _updateRequestRepoState :: IndexState + , _updateRequestRepoState :: RepoIndexState } deriving (Show) instance Pretty UpdateRequest where @@ -146,7 +146,7 @@ updateAction ( configFlags, configExFlags, installFlags ++ "\" can not be found in known remote repo(s): " ++ intercalate ", " (map unRepoName remoteRepoNames) - let reposToUpdate :: [(Repo, IndexState)] + let reposToUpdate :: [(Repo, RepoIndexState)] reposToUpdate = case updateRepoRequests of -- If we are not given any specific repository, update all -- repositories to HEAD. @@ -179,7 +179,7 @@ updateAction ( configFlags, configExFlags, installFlags haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) +updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState) -> IO () updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs index 71baf2696df..41e1443722a 100644 --- a/cabal-install/Distribution/Client/Get.hs +++ b/cabal-install/Distribution/Client/Get.hs @@ -52,7 +52,7 @@ import Distribution.Client.VCS import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState ) + ( getSourcePackagesAtIndexState, TotalIndexState ) import Distribution.Solver.Types.SourcePackage import Control.Exception @@ -86,9 +86,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do unless useSourceRepo $ mapM_ (checkTarget verbosity) userTargets - let idxState = flagToMaybe $ getIndexState getFlags + 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) diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index 236a733c947..b6ce53eb50d 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -26,10 +26,11 @@ module Distribution.Client.IndexUtils ( getSourcePackages, getSourcePackagesMonitorFiles, - IndexState(..), + TotalIndexState, getSourcePackagesAtIndexState, Index(..), + RepoIndexState (..), PackageEntry(..), parsePackageIndex, updateRepoIndexCache, @@ -177,7 +178,7 @@ emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp -- resulting index cache. -- -- Note: 'filterCache' is idempotent in the 'Cache' value -filterCache :: IndexState -> Cache -> (Cache, IndexStateInfo) +filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo) filterCache IndexStateHead cache = (cache, IndexStateInfo{..}) where isiMaxTime = cacheHeadTs cache @@ -198,7 +199,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 Nothing + fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'. @@ -206,11 +207,14 @@ getSourcePackages verbosity repoCtxt = -- 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) -getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe IndexState - -> IO SourcePackageDb +-- 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, TotalIndexState) getSourcePackagesAtIndexState verbosity repoCtxt _ | null (repoContextRepos repoCtxt) = do -- In the test suite, we routinely don't have any remote package @@ -218,25 +222,29 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ 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 = case r of - RepoRemote remote _ -> unRepoName $ remoteRepoName remote - RepoSecure remote _ -> unRepoName $ remoteRepoName remote - RepoLocalNoIndex local _ -> unRepoName $ localRepoName local - RepoLocal _ -> "" + 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 - info verbosity ("Reading available packages of " ++ rname ++ "...") + let rname = fromMaybe (RepoName "__local-repository") mrname + + info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...") idxState <- case mb_idxState of - Just idxState -> do + Just totalIdxState -> do + let idxState = lookupIndexState rname totalIdxState info verbosity $ "Using " ++ describeState idxState ++ " as explicitly requested (via command line / project configuration)" return idxState @@ -255,7 +263,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')") RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" - RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") + RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')") RepoSecure {} -> pure () let idxState' = case r of @@ -266,36 +274,59 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do case idxState' of IndexStateHead -> do - info verbosity ("index-state("++rname++") = " ++ prettyShow (isiHeadTime isi)) + info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi)) return () IndexStateTime ts0 -> do when (isiMaxTime isi /= ts0) $ if ts0 > isiMaxTime isi then warn verbosity $ "Requested index-state " ++ prettyShow ts0 - ++ " is newer than '" ++ rname ++ "'!" + ++ " is newer than '" ++ unRepoName rname ++ "'!" ++ " Falling back to older state (" ++ prettyShow (isiMaxTime isi) ++ ")." else info verbosity $ "Requested index-state " ++ prettyShow ts0 - ++ " does not exist in '"++rname++"'!" + ++ " does not exist in '"++ unRepoName rname ++"'!" ++ " Falling back to older state (" ++ prettyShow (isiMaxTime isi) ++ ")." - info verbosity ("index-state("++rname++") = " ++ + info verbosity ("index-state("++ unRepoName rname ++") = " ++ 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 @@ -311,7 +342,7 @@ readCacheStrict verbosity index mkPkg = do -- -- This is a higher level wrapper used internally in cabal-install. -- -readRepoIndex :: Verbosity -> RepoContext -> Repo -> IndexState +readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do @@ -729,7 +760,7 @@ readPackageIndexCacheFile :: Package pkg => Verbosity -> (PackageEntry -> pkg) -> Index - -> IndexState + -> RepoIndexState -> IO (PackageIndex pkg, [Dependency], IndexStateInfo) readPackageIndexCacheFile verbosity mkPkg index idxState | localNoIndex index = do @@ -922,7 +953,7 @@ writeNoIndexCache verbosity index cache = do structuredEncodeFile path cache -- | Write the 'IndexState' to the filesystem -writeIndexTimestamp :: Index -> IndexState -> IO () +writeIndexTimestamp :: Index -> RepoIndexState -> IO () writeIndexTimestamp index st = writeFile (timestampFile index) (prettyShow st) @@ -938,7 +969,7 @@ currentIndexTimestamp verbosity repoCtxt r = do return (isiHeadTime isi) -- | Read the 'IndexState' from the filesystem -readIndexTimestamp :: Index -> IO (Maybe IndexState) +readIndexTimestamp :: Index -> IO (Maybe RepoIndexState) readIndexTimestamp index = fmap simpleParsec (readFile (timestampFile index)) `catchIO` \e -> diff --git a/cabal-install/Distribution/Client/IndexUtils/IndexState.hs b/cabal-install/Distribution/Client/IndexUtils/IndexState.hs index 56ca6d069cd..15178e88990 100644 --- a/cabal-install/Distribution/Client/IndexUtils/IndexState.hs +++ b/cabal-install/Distribution/Client/IndexUtils/IndexState.hs @@ -6,41 +6,137 @@ -- Copyright : (c) 2016 Herbert Valerio Riedel -- License : BSD3 -- --- Timestamp type used in package indexes +-- Package repositories index state. +-- module Distribution.Client.IndexUtils.IndexState ( - IndexState(..), + RepoIndexState(..), + TotalIndexState, + headTotalIndexState, + makeTotalIndexState, + lookupIndexState, + insertIndexState, ) where import Distribution.Client.Compat.Prelude import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Types (RepoName (..)) import Distribution.FieldGrammar.Described import Distribution.Parsec (Parsec (..)) import Distribution.Pretty (Pretty (..)) import qualified Distribution.Compat.CharParsing as P +import qualified Data.Map.Strict as Map import qualified Text.PrettyPrint as Disp +------------------------------------------------------------------------------- +-- Total index state +------------------------------------------------------------------------------- + +-- | Index state of multiple repositories +data TotalIndexState = TIS RepoIndexState (Map RepoName RepoIndexState) + deriving (Eq, Show, Generic) + +instance Binary TotalIndexState +instance Structured TotalIndexState +instance NFData TotalIndexState + +instance Pretty TotalIndexState where + pretty (TIS IndexStateHead m) + | not (Map.null m) + = Disp.hsep + [ pretty rn <<>> Disp.colon <<>> pretty idx + | (rn, idx) <- Map.toList m + ] + pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where + go doc (rn, idx) = doc Disp.<+> pretty rn <<>> Disp.colon <<>> pretty idx + +instance Parsec TotalIndexState where + parsec = normalise . foldl' add headTotalIndexState <$> some (single0 <* P.spaces) where + -- hard to do without try + -- 2020-03-21T11:22:33Z looks like it begins with + -- repository name 2020-03-21T11 + -- + -- To make this easy, we could forbid repository names starting with digit + -- + single0 = P.try single1 <|> TokTimestamp <$> parsec + single1 = do + token <- P.munch1 (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.') + single2 token <|> single3 token + + single2 token = do + _ <- P.char ':' + idx <- parsec + return (TokRepo (RepoName token) idx) + + single3 "HEAD" = return TokHead + single3 token = P.unexpected ("Repository " ++ token ++ " without index state (after comma)") + + add :: TotalIndexState -> Tok -> TotalIndexState + add _ TokHead = headTotalIndexState + add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty + add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m) + +instance Described TotalIndexState where + describe _ = REMunch1 RESpaces1 $ REUnion + [ describe (Proxy :: Proxy RepoName) <> reChar ':' <> ris + , ris + ] + where + ris = describe (Proxy :: Proxy RepoIndexState) + +-- used in Parsec TotalIndexState implementation +data Tok + = TokRepo RepoName RepoIndexState + | TokTimestamp Timestamp + | TokHead + +-- | Remove non-default values from 'TotalIndexState'. +normalise :: TotalIndexState -> TotalIndexState +normalise (TIS def m) = TIS def (Map.filter (/= def) m) + +-- | 'TotalIndexState' where all repositories are at @HEAD@ index state. +headTotalIndexState :: TotalIndexState +headTotalIndexState = TIS IndexStateHead Map.empty + +-- | Create 'TotalIndexState'. +makeTotalIndexState :: RepoIndexState -> Map RepoName RepoIndexState -> TotalIndexState +makeTotalIndexState def m = normalise (TIS def m) + +-- | Lookup a 'RepoIndexState' for an individual repository from 'TotalIndexState'. +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 +------------------------------------------------------------------------------- + -- | Specification of the state of a specific repo package index -data IndexState = IndexStateHead -- ^ Use all available entries - | IndexStateTime !Timestamp -- ^ Use all entries that existed at - -- the specified time - deriving (Eq,Generic,Show) +data RepoIndexState + = IndexStateHead -- ^ Use all available entries + | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time + deriving (Eq,Generic,Show) -instance Binary IndexState -instance Structured IndexState -instance NFData IndexState +instance Binary RepoIndexState +instance Structured RepoIndexState +instance NFData RepoIndexState -instance Pretty IndexState where +instance Pretty RepoIndexState where pretty IndexStateHead = Disp.text "HEAD" pretty (IndexStateTime ts) = pretty ts -instance Parsec IndexState where +instance Parsec RepoIndexState where parsec = parseHead <|> parseTime where parseHead = IndexStateHead <$ P.string "HEAD" parseTime = IndexStateTime <$> parsec -instance Described IndexState where +instance Described RepoIndexState where describe _ = REUnion [ "HEAD" , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp)) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 90608416569..21cde7f1061 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index bab5d4f1972..dd3854b19ed 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -35,7 +35,7 @@ import Distribution.Client.BuildReports.Types import Distribution.Client.SourceRepo (SourceRepoList) import Distribution.Client.IndexUtils.IndexState - ( IndexState ) + ( TotalIndexState ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..) ) @@ -180,7 +180,7 @@ data ProjectConfigShared projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, projectConfigLocalNoIndexRepos :: NubList LocalRepo, - projectConfigIndexState :: Flag IndexState, + projectConfigIndexState :: Flag TotalIndexState, projectConfigStoreDir :: Flag FilePath, -- solver configuration @@ -406,7 +406,7 @@ data SolverSettings solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, solverSettingOnlyConstrained :: OnlyConstrained, - solverSettingIndexState :: Maybe IndexState, + solverSettingIndexState :: Maybe TotalIndexState, solverSettingIndependentGoals :: IndependentGoals -- Things that only make sense for manual mode, not --local mode -- too much control! diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 2f145a6528d..3613b057ba2 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index ae31ebb06da..d1615cf7972 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/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.IndexState -> 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 diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index fa491792a07..0fd24304e2d 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -78,7 +78,7 @@ import Distribution.Client.BuildReports.Types import Distribution.Client.Dependency.Types ( PreSolver(..) ) import Distribution.Client.IndexUtils.IndexState - ( IndexState(..) ) + ( TotalIndexState, headTotalIndexState ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets @@ -1334,14 +1334,14 @@ outdatedCommand = CommandUI { data UpdateFlags = UpdateFlags { updateVerbosity :: Flag Verbosity, - updateIndexState :: Flag IndexState + updateIndexState :: Flag TotalIndexState } deriving Generic defaultUpdateFlags :: UpdateFlags defaultUpdateFlags = UpdateFlags { updateVerbosity = toFlag normal, - updateIndexState = toFlag IndexStateHead + updateIndexState = toFlag headTotalIndexState } updateCommand :: CommandUI UpdateFlags @@ -1534,7 +1534,7 @@ instance Semigroup ReportFlags where data GetFlags = GetFlags { getDestDir :: Flag FilePath, getPristine :: Flag Bool, - getIndexState :: Flag IndexState, + getIndexState :: Flag TotalIndexState, getSourceRepository :: Flag (Maybe RepoKind), getVerbosity :: Flag Verbosity } deriving Generic @@ -1765,7 +1765,7 @@ data InstallFlags = InstallFlags { installUpgradeDeps :: Flag Bool, installOnly :: Flag Bool, installOnlyDeps :: Flag Bool, - installIndexState :: Flag IndexState, + installIndexState :: Flag TotalIndexState, installRootCmd :: Flag String, installSummaryFile :: NubList PathTemplate, installLogFile :: Flag PathTemplate, diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index fc94b58b09b..96edc369a4e 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -285,6 +285,7 @@ unRepoName (RepoName n) = n instance Binary RepoName instance Structured RepoName +instance NFData RepoName instance Pretty RepoName where pretty = Disp.text . unRepoName diff --git a/cabal-install/Distribution/Client/Update.hs b/cabal-install/Distribution/Client/Update.hs index 692437b531b..c59d5628e32 100644 --- a/cabal-install/Distribution/Client/Update.hs +++ b/cabal-install/Distribution/Client/Update.hs @@ -20,12 +20,13 @@ import Distribution.Simple.Setup import Distribution.Client.Compat.Directory ( setModificationTime ) import Distribution.Client.Types - ( Repo(..), RemoteRepo(..), maybeRepoRemote, unRepoName ) + ( Repo(..), RepoName (..), RemoteRepo(..), maybeRepoRemote, unRepoName ) import Distribution.Client.HttpUtils ( DownloadResult(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) import Distribution.Client.IndexUtils.Timestamp +import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils ( updateRepoIndexCache, Index(..), writeIndexTimestamp , currentIndexTimestamp, indexBaseName ) @@ -84,13 +85,20 @@ updateRepo verbosity updateFlags repoCtxt repo = do writeFileAtomic (dropExtension indexPath) . maybeDecompress =<< BS.readFile indexPath updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) - RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do + RepoSecure remote _ -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do let index = RepoIndex repoCtxt repo -- NB: This may be a nullTimestamp if we've never updated before current_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo + -- NB: always update the timestamp, even if we didn't actually -- download anything - writeIndexTimestamp index (fromFlag (updateIndexState updateFlags)) + let rname :: RepoName + rname = remoteRepoName remote + + let repoIndexState :: RepoIndexState + repoIndexState = lookupIndexState rname (fromFlag (updateIndexState updateFlags)) + writeIndexTimestamp index repoIndexState + ce <- if repoContextIgnoreExpiry repoCtxt then Just `fmap` getCurrentTime else return Nothing diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index f960e4674ab..a9b49b6bc72 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -1541,7 +1541,7 @@ planProject testdir cliConfig = do localPackages, _buildSettings) <- configureProject testdir cliConfig - (elaboratedPlan, _, elaboratedShared) <- + (elaboratedPlan, _, elaboratedShared, _) <- rebuildInstallPlan verbosity distDirLayout cabalDirLayout projectConfig diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index ef0bae0ee46..48b4bb6cd19 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -23,7 +23,7 @@ import Distribution.Utils.NubList import Distribution.Client.BuildReports.Types (ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) -import Distribution.Client.IndexUtils.IndexState (IndexState (..)) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) import Distribution.Client.InstallSymlink (OverwritePolicy) import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) @@ -137,11 +137,14 @@ instance Arbitrary Timestamp where -- arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary -instance Arbitrary IndexState where +instance Arbitrary RepoIndexState where arbitrary = frequency [ (1, pure IndexStateHead) , (50, IndexStateTime <$> arbitrary) ] +instance Arbitrary TotalIndexState where + arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary + instance Arbitrary WriteGhcEnvironmentFilesPolicy where arbitrary = arbitraryBoundedEnum diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs index a5630e0d2f4..3ebf9cf178c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs @@ -17,7 +17,7 @@ import Distribution.Pretty (prettyShow) import qualified Distribution.Utils.CharSet as CS -import Distribution.Client.IndexUtils.IndexState (IndexState) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp) import Distribution.Client.Types (RepoName) @@ -30,7 +30,8 @@ import Test.QuickCheck.Instances.Cabal () tests :: TestTree tests = testGroup "Described" [ testDescribed (Proxy :: Proxy Timestamp) - , testDescribed (Proxy :: Proxy IndexState) + , testDescribed (Proxy :: Proxy RepoIndexState) + , testDescribed (Proxy :: Proxy TotalIndexState) , testDescribed (Proxy :: Proxy RepoName) ] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index 08ae14490dc..fcc874d1101 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -48,6 +48,8 @@ instance (ToExpr k, ToExpr v) => ToExpr (MapLast k v) instance (ToExpr a) => ToExpr (NubList a) instance (ToExpr a) => ToExpr (Flag a) +instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f) + instance ToExpr AllowBootLibInstalls instance ToExpr AllowNewer instance ToExpr AllowOlder @@ -61,7 +63,6 @@ instance ToExpr FlagAssignment instance ToExpr FlagName where toExpr = defaultExprViaShow instance ToExpr HaddockTarget instance ToExpr IndependentGoals -instance ToExpr IndexState instance ToExpr InstallMethod instance ToExpr LocalRepo instance ToExpr MinimizeConflictSet @@ -84,22 +85,23 @@ instance ToExpr ProjectConfigBuildOnly instance ToExpr ProjectConfigProvenance instance ToExpr ProjectConfigShared instance ToExpr RelaxDepMod +instance ToExpr RelaxDeps instance ToExpr RelaxDepScope instance ToExpr RelaxDepSubject -instance ToExpr RelaxDeps instance ToExpr RelaxedDep instance ToExpr RemoteRepo instance ToExpr ReorderGoals +instance ToExpr RepoIndexState instance ToExpr RepoKind instance ToExpr RepoName -instance ToExpr RepoType instance ToExpr ReportLevel +instance ToExpr RepoType instance ToExpr ShortText instance ToExpr SourceRepo -instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f) instance ToExpr StrongFlags instance ToExpr TestShowDetails instance ToExpr Timestamp +instance ToExpr TotalIndexState instance ToExpr URI instance ToExpr URIAuth instance ToExpr UserConstraint