Add active-repositories configuration

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

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:

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
 ^^^^^^^^^^^^^^^^^^^^^^^^^
 

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,

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)

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

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'.
 --