diff --git a/Cabal/Distribution/Utils/GrammarRegex.hs b/Cabal/Distribution/Utils/GrammarRegex.hs index 403842e6668..bf9f53ca071 100644 --- a/Cabal/Distribution/Utils/GrammarRegex.hs +++ b/Cabal/Distribution/Utils/GrammarRegex.hs @@ -50,7 +50,7 @@ data GrammarRegex a | RESpaces -- ^ zero-or-more spaces | RESpaces1 -- ^ one-or-more spaces | RECommaList (GrammarRegex a) -- ^ comma list (note, leading or trailing commas) - | RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list + | RECommaNonEmpty (GrammarRegex a) -- ^ comma non-empty list (note, leading or trailing commas) | REOptCommaList (GrammarRegex a) -- ^ opt comma list | RETodo -- ^ unspecified diff --git a/Cabal/doc/cabal-project.rst b/Cabal/doc/cabal-project.rst index 9f92e70c94b..45856d2f5f5 100644 --- a/Cabal/doc/cabal-project.rst +++ b/Cabal/doc/cabal-project.rst @@ -433,6 +433,37 @@ The following settings control the behavior of the dependency solver: -- for storing `--index-state` values. index-state: 2016-09-24T17:47:48Z + -- Specify different index-states per package repository + -- Supported since 3.4 + index-state: + , hackage.haskell.org 2020-05-06T22:33:27Z + , head.hackage 2020-04-29T04:11:05Z + +.. cfg-field:: active-repositories: reponame1, reponame2 + + :synopsis: Specify active package repositories + :since: 3.4 + + :default: ``:rest`` + + This allows to specify the active package repositories, + when multiple are specified. This is useful as you + can specify the order and the way active repositories are merged. + + :: + + -- for packages in head.hackage + -- only versions in head.hackage are considered + active-repositories: + , hackage.haskell.org + , head.hackage:override + + -- Force head.hackage to be the primary repository considered + active-repositories: :rest, head.hackage + + -- "Offline" mode + active-repositories: none + .. cfg-field:: reject-unconstrained-dependencies: all, none --reject-unconstrained-dependencies=[all|none] @@ -1377,15 +1408,6 @@ Advanced global configuration options The command line variant of this flag is ``--build-summary=TEMPLATE``. -.. cfg-field:: local-repo: directory - --local-repo=DIR - :deprecated: - - [STRIKEOUT:The location of a local repository.] Deprecated. See - "Legacy repositories." - - The command line variant of this flag is ``--local-repo=DIR``. - .. cfg-field:: world-file: path --world-file=FILE :deprecated: diff --git a/Cabal/doc/installing-packages.rst b/Cabal/doc/installing-packages.rst index 291fa8bda79..30af8ed1335 100644 --- a/Cabal/doc/installing-packages.rst +++ b/Cabal/doc/installing-packages.rst @@ -188,8 +188,8 @@ The part of the path will be used to determine the cache key part. Legacy repositories ^^^^^^^^^^^^^^^^^^^ -Currently ``cabal`` supports two kinds of “legacy” repositories. The -first is specified using +Currently ``cabal`` supports single kind of “legacy” repositories. +It is specified using :: @@ -206,18 +206,6 @@ although, in (and only in) the specific case of Hackage, the URL ``http://hackage.haskell.org/packages/archive`` will be silently translated to ``http://hackage.haskell.org/``. -The second kind of legacy repositories are so-called “(legacy) local” -repositories: - -:: - - local-repo: my-local-repo:/path/to/local/repo - -This can be used to access repositories on the local file system. -However, the layout of these local repositories is different from the -layout of remote repositories, and usage of these local repositories is -deprecated. - Secure local repositories ^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index 35166cdd811..93ba0200da8 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -251,6 +251,7 @@ instance Semigroup SavedConfig where globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, + globalActiveRepos = combine globalActiveRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalIgnoreExpiry = combine globalIgnoreExpiry, diff --git a/cabal-install/Distribution/Client/Get.hs b/cabal-install/Distribution/Client/Get.hs index 925897f4b63..bac80071093 100644 --- a/cabal-install/Distribution/Client/Get.hs +++ b/cabal-install/Distribution/Client/Get.hs @@ -51,8 +51,8 @@ import Distribution.Client.Dependency import Distribution.Client.VCS import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils as IndexUtils - ( getSourcePackagesAtIndexState, TotalIndexState ) +import Distribution.Client.IndexUtils + ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) import Distribution.Solver.Types.SourcePackage import Control.Exception @@ -89,7 +89,10 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do let idxState :: Maybe TotalIndexState idxState = flagToMaybe $ getIndexState getFlags - (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState + activeRepos :: Maybe ActiveRepos + activeRepos = flagToMaybe $ getActiveRepos getFlags + + (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos pkgSpecifiers <- resolveUserTargets verbosity repoCtxt (fromFlag $ globalWorldFile globalFlags) diff --git a/cabal-install/Distribution/Client/GlobalFlags.hs b/cabal-install/Distribution/Client/GlobalFlags.hs index 68d20cd720d..c011dc4e149 100644 --- a/cabal-install/Distribution/Client/GlobalFlags.hs +++ b/cabal-install/Distribution/Client/GlobalFlags.hs @@ -29,6 +29,9 @@ import Distribution.Verbosity import Distribution.Simple.Utils ( info, warn ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) + import Control.Concurrent ( MVar, newMVar, modifyMVar ) import Control.Exception @@ -55,47 +58,50 @@ import qualified System.FilePath.Posix as FilePath.Posix -- ------------------------------------------------------------ -- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool, - globalConfigFile :: Flag FilePath, - globalConstraintsFile :: Flag FilePath, - globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. - globalCacheDir :: Flag FilePath, - globalLocalNoIndexRepos :: NubList LocalRepo, - globalLogsDir :: Flag FilePath, - globalWorldFile :: Flag FilePath, - globalIgnoreExpiry :: Flag Bool, -- ^ Ignore security expiry dates - globalHttpTransport :: Flag String, - globalNix :: Flag Bool, -- ^ Integrate with Nix - globalStoreDir :: Flag FilePath, - globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) - } deriving Generic + +data GlobalFlags = GlobalFlags + { globalVersion :: Flag Bool + , globalNumericVersion :: Flag Bool + , globalConfigFile :: Flag FilePath + , globalConstraintsFile :: Flag FilePath + , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers. + , globalCacheDir :: Flag FilePath + , globalLocalNoIndexRepos :: NubList LocalRepo + , globalActiveRepos :: Flag ActiveRepos + , globalLogsDir :: Flag FilePath + , globalWorldFile :: Flag FilePath + , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates + , globalHttpTransport :: Flag String + , globalNix :: Flag Bool -- ^ Integrate with Nix + , globalStoreDir :: Flag FilePath + , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports) + } deriving Generic defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False, - globalConfigFile = mempty, - globalConstraintsFile = mempty, - globalRemoteRepos = mempty, - globalCacheDir = mempty, - globalLocalNoIndexRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty, - globalIgnoreExpiry = Flag False, - globalHttpTransport = mempty, - globalNix = Flag False, - globalStoreDir = mempty, - globalProgPathExtra = mempty - } +defaultGlobalFlags = GlobalFlags + { globalVersion = Flag False + , globalNumericVersion = Flag False + , globalConfigFile = mempty + , globalConstraintsFile = mempty + , globalRemoteRepos = mempty + , globalCacheDir = mempty + , globalLocalNoIndexRepos = mempty + , globalActiveRepos = mempty + , globalLogsDir = mempty + , globalWorldFile = mempty + , globalIgnoreExpiry = Flag False + , globalHttpTransport = mempty + , globalNix = Flag False + , globalStoreDir = mempty + , globalProgPathExtra = mempty + } instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) + mempty = gmempty + mappend = (<>) instance Semigroup GlobalFlags where - (<>) = gmappend + (<>) = gmappend -- ------------------------------------------------------------ -- * Repo context diff --git a/cabal-install/Distribution/Client/IndexUtils.hs b/cabal-install/Distribution/Client/IndexUtils.hs index 75cc5969e86..2e27ab6372c 100644 --- a/cabal-install/Distribution/Client/IndexUtils.hs +++ b/cabal-install/Distribution/Client/IndexUtils.hs @@ -28,6 +28,7 @@ module Distribution.Client.IndexUtils ( TotalIndexState, getSourcePackagesAtIndexState, + ActiveRepos, Index(..), RepoIndexState (..), @@ -48,6 +49,7 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Archive.Tar.Index as Tar import qualified Distribution.Client.Tar as Tar +import Distribution.Client.IndexUtils.ActiveRepos import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types @@ -69,8 +71,9 @@ import Distribution.Simple.Program ( ProgramDb ) import qualified Distribution.Simple.Configure as Configure ( getInstalledPackages, getInstalledPackagesMonitorFiles ) +import Distribution.Types.PackageName (PackageName) import Distribution.Version - ( Version, mkVersion, intersectVersionRanges ) + ( Version, VersionRange, mkVersion, intersectVersionRanges ) import Distribution.Deprecated.Text ( display, simpleParse ) import Distribution.Simple.Utils @@ -197,7 +200,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 = - fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing + fst <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing -- | Variant of 'getSourcePackages' which allows getting the source -- packages at a particular 'IndexState'. @@ -212,8 +215,9 @@ getSourcePackagesAtIndexState :: Verbosity -> RepoContext -> Maybe TotalIndexState + -> Maybe ActiveRepos -> IO (SourcePackageDb, TotalIndexState) -getSourcePackagesAtIndexState verbosity repoCtxt _ +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 @@ -224,7 +228,7 @@ getSourcePackagesAtIndexState verbosity repoCtxt _ packageIndex = mempty, packagePreferences = mempty }, headTotalIndexState) -getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do +getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do let describeState IndexStateHead = "most recent state" describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time @@ -288,40 +292,59 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState = do prettyShow (isiHeadTime isi) ++ ")") pure RepoData - { rdIndexStates = [(rname, isiMaxTime isi)] + { rdRepoName = rname + , rdTimeStamp = isiMaxTime isi , rdIndex = pis , rdPreferences = deps } - 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 + let activeRepos :: ActiveRepos + activeRepos = fromMaybe defaultActiveRepos mb_activeRepos + + pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of + Right x -> return x + Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss) + + let totalIndexState :: TotalIndexState + totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList + [ (n, IndexStateTime ts) + | (RepoData n ts _idx _prefs, _strategy) <- pkgss' + ] + + let addIndex + :: PackageIndex UnresolvedSourcePackage + -> (RepoData, CombineStrategy) + -> PackageIndex UnresolvedSourcePackage + addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx + addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx + + let pkgs :: PackageIndex UnresolvedSourcePackage + pkgs = foldl' addIndex mempty pkgss' + + -- Note: preferences combined without using CombineStrategy + let prefs :: Map PackageName VersionRange + prefs = Map.fromListWith intersectVersionRanges + [ (name, range) + | (RepoData _n _ts _idx prefs', _strategy) <- pkgss' + , Dependency name range _ <- prefs' + ] + _ <- evaluate pkgs - _ <- evaluate prefs' + _ <- evaluate prefs _ <- evaluate totalIndexState return (SourcePackageDb { packageIndex = pkgs, - packagePreferences = prefs' + packagePreferences = prefs }, totalIndexState) -- auxiliary data used in getSourcePackagesAtIndexState data RepoData = RepoData - { rdIndexStates :: [(RepoName, Timestamp)] + { rdRepoName :: RepoName + , rdTimeStamp :: 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 = (<>) - -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. -- diff --git a/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs new file mode 100644 index 00000000000..0bf562c8d2d --- /dev/null +++ b/cabal-install/Distribution/Client/IndexUtils/ActiveRepos.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Distribution.Client.IndexUtils.ActiveRepos ( + ActiveRepos (..), + defaultActiveRepos, + ActiveRepoEntry (..), + CombineStrategy (..), + organizeByRepos, +) where + +import Distribution.Client.Compat.Prelude +import Distribution.Client.Types.RepoName (RepoName (..)) +import Prelude () + +import Distribution.FieldGrammar.Described +import Distribution.Parsec (Parsec (..), parsecLeadingCommaList) +import Distribution.Pretty (Pretty (..), prettyShow) + +import qualified Distribution.Compat.CharParsing as P +import qualified Text.PrettyPrint as Disp + +-- $setup +-- >>> import Distribution.Parsec + +------------------------------------------------------------------------------- +-- Types +------------------------------------------------------------------------------- + +-- | Ordered list of active repositories. +newtype ActiveRepos = ActiveRepos [ActiveRepoEntry] + deriving (Eq, Show, Generic) + +defaultActiveRepos :: ActiveRepos +defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ] + +instance Binary ActiveRepos +instance Structured ActiveRepos +instance NFData ActiveRepos + +instance Pretty ActiveRepos where + pretty (ActiveRepos []) + = Disp.text ":none" + pretty (ActiveRepos repos) + = Disp.hsep + $ Disp.punctuate Disp.comma + $ map pretty repos + +-- | Note: empty string is not valid 'ActiveRepos'. +-- +-- >>> simpleParsec "" :: Maybe ActiveRepos +-- Nothing +-- +-- >>> simpleParsec ":none" :: Maybe ActiveRepos +-- Just (ActiveRepos []) +-- +-- >>> simpleParsec ":rest" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) +-- +-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos +-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride]) +-- +instance Parsec ActiveRepos where + parsec = ActiveRepos [] <$ P.try (P.string ":none") + <|> do + repos <- parsecLeadingCommaList parsec + return (ActiveRepos (toList repos)) + +instance Described ActiveRepos where + describe _ = REUnion + [ ":none" + , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry)) + ] + +data ActiveRepoEntry + = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo' + | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name + deriving (Eq, Show, Generic) + +instance Binary ActiveRepoEntry +instance Structured ActiveRepoEntry +instance NFData ActiveRepoEntry + +instance Pretty ActiveRepoEntry where + pretty (ActiveRepoRest s) = + Disp.text ":rest" <<>> Disp.colon <<>> pretty s + pretty (ActiveRepo r s) = + pretty r <<>> Disp.colon <<>> pretty s + +instance Parsec ActiveRepoEntry where + parsec = leadColon <|> leadRepo where + leadColon = do + _ <- P.char ':' + token <- P.munch1 isAlpha + case token of + "rest" -> ActiveRepoRest <$> strategyP + "repo" -> P.char ':' *> leadRepo + _ -> P.unexpected $ "Unknown active repository entry type: " ++ token + + leadRepo = do + r <- parsec + s <- strategyP + return (ActiveRepo r s) + + strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec) + +instance Described ActiveRepoEntry where + describe _ = REUnion + [ ":rest" <> strategy + , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy + ] + where + strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy) + +data CombineStrategy + = CombineStrategyMerge -- ^ merge existing versions + | CombineStrategyOverride -- ^ if later repository specifies a package, + -- all package versions are replaced + deriving (Eq, Show, Enum, Bounded, Generic) + +instance Binary CombineStrategy +instance Structured CombineStrategy +instance NFData CombineStrategy + +instance Pretty CombineStrategy where + pretty CombineStrategyMerge = Disp.text "merge" + pretty CombineStrategyOverride = Disp.text "override" + +instance Parsec CombineStrategy where + parsec = P.choice + [ CombineStrategyMerge <$ P.string "merge" + , CombineStrategyOverride <$ P.string "override" + ] + +instance Described CombineStrategy where + describe _ = REUnion + [ "merge" + , "override" + ] + +------------------------------------------------------------------------------- +-- Organisation +------------------------------------------------------------------------------- + +-- | Sort values 'RepoName' according to 'ActiveRepos' list. +-- +-- >>> let repos = [RepoName "a", RepoName "b", RepoName "c"] +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "b",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepo (RepoName "b") CombineStrategyOverride, ActiveRepoRest CombineStrategyMerge]) id repos +-- Right [(RepoName "b",CombineStrategyOverride),(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "b") CombineStrategyOverride]) id repos +-- Right [(RepoName "a",CombineStrategyMerge),(RepoName "c",CombineStrategyMerge),(RepoName "b",CombineStrategyOverride)] +-- +-- >>> organizeByRepos (ActiveRepos [ActiveRepoRest CombineStrategyMerge, ActiveRepo (RepoName "d") CombineStrategyOverride]) id repos +-- Left "no repository provided d" +-- +-- Note: currently if 'ActiveRepoRest' is provided more than once, +-- rest-repositories will be multiple times in the output. +-- +organizeByRepos + :: forall a. ActiveRepos + -> (a -> RepoName) + -> [a] + -> Either String [(a, CombineStrategy)] +organizeByRepos (ActiveRepos xs0) sel ys0 = + -- here we use lazyness to do only one traversal + let (rest, result) = case go rest xs0 ys0 of + Right (rest', result') -> (rest', Right result') + Left err -> ([], Left err) + in result + where + go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)]) + go _rest [] ys = Right (ys, []) + go rest (ActiveRepoRest s : xs) ys = + go rest xs ys <&> \(rest', result) -> + (rest', map (\x -> (x, s)) rest ++ result) + go rest (ActiveRepo r s : xs) ys = do + (z, zs) <- extract r ys + go rest xs zs <&> \(rest', result) -> + (rest', (z, s) : result) + + extract :: RepoName -> [a] -> Either String (a, [a]) + extract r = loop id where + loop _acc [] = Left $ "no repository provided " ++ prettyShow r + loop acc (x:xs) + | sel x == r = Right (x, acc xs) + | otherwise = loop (acc . (x :)) xs + + (<&>) + :: Either err ([s], b) + -> (([s], b) -> ([s], c)) + -> Either err ([s], c) + (<&>) = flip fmap diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index bc855272c9d..59d8ab5acee 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -272,7 +272,7 @@ makeInstallContext verbosity let idxState = flagToMaybe (installIndexState installFlags) installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb - (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState + (sourcePkgDb, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing pkgConfigDb <- readPkgConfigDb verbosity progdb checkConfigExFlags verbosity installedPkgIndex diff --git a/cabal-install/Distribution/Client/ProjectConfig.hs b/cabal-install/Distribution/Client/ProjectConfig.hs index 5a9cc29bfab..cd6d7733d52 100644 --- a/cabal-install/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/Distribution/Client/ProjectConfig.hs @@ -253,6 +253,7 @@ resolveSolverSettings ProjectConfig{ solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained solverSettingIndexState = flagToMaybe projectConfigIndexState + solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs --solverSettingReinstall = fromFlag projectConfigReinstall diff --git a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 1370b3f7c5b..67e1d4297d0 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -335,6 +335,7 @@ convertLegacyAllPackageFlags globalFlags configFlags globalConfigFile = projectConfigConfigFile, globalRemoteRepos = projectConfigRemoteRepos, globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, globalProgPathExtra = projectConfigProgPathExtra, globalStoreDir = projectConfigStoreDir } = globalFlags @@ -569,6 +570,7 @@ convertToLegacySharedConfig globalRemoteRepos = projectConfigRemoteRepos, globalCacheDir = projectConfigCacheDir, globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, + globalActiveRepos = projectConfigActiveRepos, globalLogsDir = projectConfigLogsDir, globalWorldFile = mempty, globalIgnoreExpiry = projectConfigIgnoreExpiry, @@ -939,6 +941,7 @@ legacySharedConfigFieldDescrs = . filterFields [ "remote-repo-cache" , "logs-dir", "store-dir", "ignore-expiry", "http-transport" + , "active-repositories" ] . commandOptionsToFields ) (commandOptions (globalCommand []) ParseArgs) diff --git a/cabal-install/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/Distribution/Client/ProjectConfig/Types.hs index d9372162a62..7c309c90918 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Types.hs @@ -36,6 +36,8 @@ import Distribution.Client.Types.SourceRepo (SourceRepoList) import Distribution.Client.IndexUtils.IndexState ( TotalIndexState ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..) ) @@ -180,6 +182,7 @@ data ProjectConfigShared -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalNoIndexRepos :: NubList LocalRepo, + projectConfigActiveRepos :: Flag ActiveRepos, projectConfigIndexState :: Flag TotalIndexState, projectConfigStoreDir :: Flag FilePath, @@ -406,6 +409,7 @@ data SolverSettings solverSettingAllowBootLibInstalls :: AllowBootLibInstalls, solverSettingOnlyConstrained :: OnlyConstrained, solverSettingIndexState :: Maybe TotalIndexState, + solverSettingActiveRepos :: Maybe ActiveRepos, solverSettingIndependentGoals :: IndependentGoals -- Things that only make sense for manual mode, not --local mode -- too much control! diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 59c7eadb6d0..222324b1667 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -566,6 +566,7 @@ rebuildInstallPlan verbosity corePackageDbs (sourcePkgDb, tis)<- getSourcePackages verbosity withRepoCtx (solverSettingIndexState solverSettings) + (solverSettingActiveRepos solverSettings) pkgConfigDB <- getPkgConfigDb verbosity progdb --TODO: [code cleanup] it'd be better if the Compiler contained the @@ -764,13 +765,13 @@ getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a) -> Maybe IndexUtils.TotalIndexState + -> Maybe IndexUtils.ActiveRepos -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState) -getSourcePackages verbosity withRepoCtx idxState = do +getSourcePackages verbosity withRepoCtx idxState activeRepos = do (sourcePkgDbWithTIS, repos) <- liftIO $ withRepoCtx $ \repoctx -> do - sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity - repoctx idxState + sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos return (sourcePkgDbWithTIS, repoContextRepos repoctx) mapM_ needIfExists diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index c763a2316b8..0d026524f9f 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -71,6 +71,8 @@ import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.Dependency.Types ( PreSolver(..) ) +import Distribution.Client.IndexUtils.ActiveRepos + ( ActiveRepos ) import Distribution.Client.IndexUtils.IndexState ( TotalIndexState, headTotalIndexState ) import qualified Distribution.Client.Init.Types as IT @@ -388,6 +390,7 @@ globalCommand commands = CommandUI { "Nix integration: run commands through nix-shell if a 'shell.nix' file exists" globalNix (\v flags -> flags { globalNix = v }) (boolOpt [] []) + ] -- arguments we don't want shown in the help @@ -422,6 +425,13 @@ globalCommand commands = CommandUI { "The location of the nix-local-build store" globalStoreDir (\v flags -> flags { globalStoreDir = v }) (reqArgFlag "DIR") + + , option [] ["active-repositories"] + "The active package repositories" + globalActiveRepos (\v flags -> flags { globalActiveRepos = v }) + (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err) + (toFlag `fmap` parsec)) + (map prettyShow . flagToList)) ] -- ------------------------------------------------------------ @@ -1430,6 +1440,7 @@ data GetFlags = GetFlags { getDestDir :: Flag FilePath, getPristine :: Flag Bool, getIndexState :: Flag TotalIndexState, + getActiveRepos :: Flag ActiveRepos, getSourceRepository :: Flag (Maybe RepoKind), getVerbosity :: Flag Verbosity } deriving Generic @@ -1439,6 +1450,7 @@ defaultGetFlags = GetFlags { getDestDir = mempty, getPristine = mempty, getIndexState = mempty, + getActiveRepos = mempty, getSourceRepository = mempty, getVerbosity = toFlag normal } diff --git a/cabal-install/Distribution/Solver/Types/PackageIndex.hs b/cabal-install/Distribution/Solver/Types/PackageIndex.hs index 27e894c1e9f..b37ee115802 100644 --- a/cabal-install/Distribution/Solver/Types/PackageIndex.hs +++ b/cabal-install/Distribution/Solver/Types/PackageIndex.hs @@ -21,6 +21,7 @@ module Distribution.Solver.Types.PackageIndex ( -- * Updates merge, + override, insert, deletePackageName, deletePackageId, @@ -159,6 +160,7 @@ merge i1@(PackageIndex m1) i2@(PackageIndex m2) = assert (invariant i1 && invariant i2) $ mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + -- | Elements in the second list mask those in the first. mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] mergeBuckets [] ys = ys @@ -169,6 +171,16 @@ mergeBuckets xs@(x:xs') ys@(y:ys') = EQ -> y : mergeBuckets xs' ys' LT -> x : mergeBuckets xs' ys +-- | Override-merge oftwo indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +override i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) + -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 06cb96f3922..6567005e2bb 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -201,6 +201,7 @@ executable cabal Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.ActiveRepos Distribution.Client.IndexUtils.IndexState Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init diff --git a/cabal-install/cabal-install.cabal.pp b/cabal-install/cabal-install.cabal.pp index 191428e9ee1..45b547caa0a 100644 --- a/cabal-install/cabal-install.cabal.pp +++ b/cabal-install/cabal-install.cabal.pp @@ -140,6 +140,7 @@ Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils + Distribution.Client.IndexUtils.ActiveRepos Distribution.Client.IndexUtils.IndexState Distribution.Client.IndexUtils.Timestamp Distribution.Client.Init diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 85208528719..0d6833a4eca 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -29,6 +29,7 @@ import Distribution.Utils.NubList import Distribution.Client.BuildReports.Types (ReportLevel (..)) import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod) +import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos (..), ActiveRepoEntry (..), CombineStrategy (..)) import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState) import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp) import Distribution.Client.InstallSymlink (OverwritePolicy) @@ -100,6 +101,11 @@ arbitraryURIPort = -- cabal-install (and Cabal) types ------------------------------------------------------------------------------- +shrinkBoundedEnum :: (Eq a, Enum a, Bounded a) => a -> [a] +shrinkBoundedEnum x + | x == minBound = [] + | otherwise = [pred x] + adjustSize :: (Int -> Int) -> Gen a -> Gen a adjustSize adjust gen = sized (\n -> resize (adjust n) gen) @@ -201,3 +207,16 @@ instance Arbitrary OverwritePolicy where instance Arbitrary InstallMethod where arbitrary = arbitraryBoundedEnum + +instance Arbitrary ActiveRepos where + arbitrary = ActiveRepos <$> shortListOf 5 arbitrary + +instance Arbitrary ActiveRepoEntry where + arbitrary = frequency + [ (10, ActiveRepo <$> arbitrary <*> arbitrary) + , (1, ActiveRepoRest <$> arbitrary) + ] + +instance Arbitrary CombineStrategy where + arbitrary = arbitraryBoundedEnum + shrink = shrinkBoundedEnum diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs index 31c4f385a20..5cf3a7be295 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs @@ -11,15 +11,17 @@ import Test.QuickCheck (Arbitrary (..), Gen, Property, choose, counterexam import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (testProperty) -import Distribution.FieldGrammar.Described (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList) +import Distribution.FieldGrammar.Described + (Described (..), GrammarRegex (..), reComma, reSpacedComma, reSpacedList) import Distribution.Parsec (eitherParsec) import Distribution.Pretty (prettyShow) import qualified Distribution.Utils.CharSet as CS -import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) -import Distribution.Client.IndexUtils.Timestamp (Timestamp) -import Distribution.Client.Types (RepoName) +import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos) +import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState) +import Distribution.Client.IndexUtils.Timestamp (Timestamp) +import Distribution.Client.Types (RepoName) import qualified RERE as RE import qualified RERE.CharSet as RE @@ -33,6 +35,7 @@ tests = testGroup "Described" , testDescribed (Proxy :: Proxy RepoIndexState) , testDescribed (Proxy :: Proxy TotalIndexState) , testDescribed (Proxy :: Proxy RepoName) + , testDescribed (Proxy :: Proxy ActiveRepos) ] ------------------------------------------------------------------------------- diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 1e9bcbf7390..7ffc6e7d01c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -152,13 +152,13 @@ prop_roundtrip_legacytypes_specific config = roundtrip_printparse :: ProjectConfig -> Property roundtrip_printparse config = - case (fmap convertLegacyProjectConfig - . parseLegacyProjectConfig - . showLegacyProjectConfig - . convertToLegacyProjectConfig) - config of - ParseOk _ x -> x `ediffEq` config { projectConfigProvenance = mempty } + case fmap convertLegacyProjectConfig (parseLegacyProjectConfig str) of + ParseOk _ x -> counterexample ("shown: " ++ str) $ + config { projectConfigProvenance = mempty } `ediffEq` x ParseFailed err -> counterexample (show err) False + where + str :: String + str = showLegacyProjectConfig (convertToLegacyProjectConfig config) prop_roundtrip_printparse_all :: ProjectConfig -> Property @@ -439,32 +439,38 @@ instance Arbitrary ProjectConfigBuildOnly where postShrink_NumJobs = fmap (fmap getPositive) instance Arbitrary ProjectConfigShared where - arbitrary = - ProjectConfigShared - <$> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryConstraints - <*> shortListOf 2 arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (toNubList <$> listOf arbitraryShortToken) + arbitrary = do + projectConfigDistDir <- arbitraryFlag arbitraryShortToken + projectConfigConfigFile <- arbitraryFlag arbitraryShortToken + projectConfigProjectFile <- arbitraryFlag arbitraryShortToken + projectConfigHcFlavor <- arbitrary + projectConfigHcPath <- arbitraryFlag arbitraryShortToken + projectConfigHcPkg <- arbitraryFlag arbitraryShortToken + projectConfigHaddockIndex <- arbitrary + projectConfigRemoteRepos <- arbitrary + projectConfigLocalNoIndexRepos <- arbitrary + projectConfigActiveRepos <- arbitrary + projectConfigIndexState <- arbitrary + projectConfigStoreDir <- arbitraryFlag arbitraryShortToken + projectConfigConstraints <- arbitraryConstraints + projectConfigPreferences <- shortListOf 2 arbitrary + projectConfigCabalVersion <- arbitrary + projectConfigSolver <- arbitrary + projectConfigAllowOlder <- arbitrary + projectConfigAllowNewer <- arbitrary + projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary + projectConfigMaxBackjumps <- arbitrary + projectConfigReorderGoals <- arbitrary + projectConfigCountConflicts <- arbitrary + projectConfigFineGrainedConflicts <- arbitrary + projectConfigMinimizeConflictSet <- arbitrary + projectConfigStrongFlags <- arbitrary + projectConfigAllowBootLibInstalls <- arbitrary + projectConfigOnlyConstrained <- arbitrary + projectConfigPerComponent <- arbitrary + projectConfigIndependentGoals <- arbitrary + projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken + return ProjectConfigShared {..} where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = @@ -480,6 +486,7 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigHaddockIndex <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos + <*> shrinker projectConfigActiveRepos <*> shrinker projectConfigIndexState <*> shrinker projectConfigStoreDir <*> shrinkerPP preShrink_Constraints postShrink_Constraints projectConfigConstraints diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index c7cc3a4d87f..e9cbad2a63b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -30,6 +30,7 @@ import Distribution.Solver.Types.Settings import Distribution.Client.BuildReports.Types import Distribution.Client.CmdInstall.ClientInstallFlags import Distribution.Client.Dependency.Types +import Distribution.Client.IndexUtils.ActiveRepos import Distribution.Client.IndexUtils.IndexState import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.InstallSymlink @@ -50,10 +51,13 @@ instance (ToExpr a) => ToExpr (Flag a) instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f) +instance ToExpr ActiveRepos +instance ToExpr ActiveRepoEntry instance ToExpr AllowBootLibInstalls instance ToExpr AllowNewer instance ToExpr AllowOlder instance ToExpr ClientInstallFlags +instance ToExpr CombineStrategy instance ToExpr CompilerFlavor instance ToExpr ConstraintSource instance ToExpr CountConflicts diff --git a/changelog.d/active-repositories b/changelog.d/active-repositories new file mode 100644 index 00000000000..306bb08082b --- /dev/null +++ b/changelog.d/active-repositories @@ -0,0 +1,3 @@ +synopsis: Add active-repositories configuration +packages: cabal-install +prs: #6724