cabal-install: Clarify the semantics of package-db flag

In this PR we make the `--package-db` flag apply only to the default immutable initial package stack rather than also applying to the store package database. There are two special package databases which cabal install knows about and treats specially. * The store directory, a global cache of installed packages where cabal builds and installs packages into. * The inplace directory, a local build folder for packages, where cabal builds local packages in. It is very important that cabal registers packages it builds into one of these two locations as there are many assumptions that packages will end up here. With the current design of the `--package-db` flag, you are apparently allowed to override the store location which should have the effect of making the last package database in the package stack the "store" directory. Perhaps this works out in theory but practically this behaviour was broken and things were always registered into the store directory that cabal knew about. (The assertion in `ProjectBuilding.UnpackedPackage` was failing (see added test)). With `--package-db` not being able to modify the location of the store directory then the interaction of `--package-db`, `--store-dir` and `--dist-dir` flags become easy to understand. * `--package-db` modify the initial package database stack, these package database will not be mutated by cabal and provide the initial package environment which is used by cabal. * `--store-dir` modify the location of the store directory * `--dist-dir` modify the location of the dist directory (and hence inplace package database) Treating the flags in this way also fix an assertion failure when building packages. Fixes haskell#9678
mpickering · Feb 25, 2024 · d626ef8 · d626ef8
1 parent fb3f4d4
commit d626ef8
Show file tree

Hide file tree

Showing 18 changed files with 147 additions and 35 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -412,6 +412,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
           , projectConfigHcPkg
           , projectConfigStoreDir
           , projectConfigProgPathExtra
+          , projectConfigPackageDBs
           }
       , projectConfigLocalPackages =
         PackageConfig
@@ -443,7 +444,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
   envFile <- getEnvFile clientInstallFlags platform compilerVersion
   existingEnvEntries <-
     getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
-  packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir
+  packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir projectConfigPackageDBs
   installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb
 
   let
@@ -1281,13 +1282,14 @@ getPackageDbStack
   :: Compiler
   -> Flag FilePath
   -> Flag FilePath
+  -> [Maybe PackageDB]
   -> IO PackageDBStack
-getPackageDbStack compiler storeDirFlag logsDirFlag = do
+getPackageDbStack compiler storeDirFlag logsDirFlag packageDbs = do
   mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
   let
     mlogsDir = flagToMaybe logsDirFlag
   cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
-  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler
+  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler packageDbs
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs
@@ -46,6 +46,7 @@ import Distribution.Simple.Compiler
   , PackageDB (..)
   , PackageDBStack
   )
+import Distribution.Simple.Configure (interpretPackageDbFlags)
 import Distribution.System
 import Distribution.Types.ComponentName
 import Distribution.Types.LibraryName
@@ -121,7 +122,7 @@ data StoreDirLayout = StoreDirLayout
   , storePackageDirectory :: Compiler -> UnitId -> FilePath
   , storePackageDBPath :: Compiler -> FilePath
   , storePackageDB :: Compiler -> PackageDB
-  , storePackageDBStack :: Compiler -> PackageDBStack
+  , storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack
   , storeIncomingDirectory :: Compiler -> FilePath
   , storeIncomingLock :: Compiler -> UnitId -> FilePath
   }
@@ -286,9 +287,10 @@ defaultStoreDirLayout storeRoot =
     storePackageDB compiler =
       SpecificPackageDB (storePackageDBPath compiler)
 
-    storePackageDBStack :: Compiler -> PackageDBStack
-    storePackageDBStack compiler =
-      [GlobalPackageDB, storePackageDB compiler]
+    storePackageDBStack :: Compiler -> [Maybe PackageDB] -> PackageDBStack
+    storePackageDBStack compiler extraPackageDB =
+      (interpretPackageDbFlags False extraPackageDB)
+        ++ [storePackageDB compiler]
 
     storeIncomingDirectory :: Compiler -> FilePath
     storeIncomingDirectory compiler =

diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -683,12 +683,12 @@ buildAndInstallUnpackedPackage
                 | otherwise = do
                     assert
                       ( elabRegisterPackageDBStack pkg
-                          == storePackageDBStack compiler
+                          == storePackageDBStack compiler (elabPackageDbs pkg)
                       )
                       (return ())
                     _ <-
                       runRegister
-                        (storePackageDBStack compiler)
+                        (elabRegisterPackageDBStack pkg)
                         Cabal.defaultRegisterOptions
                           { Cabal.registerMultiInstance = True
                           , Cabal.registerSuppressFilesCheck = True

diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -295,6 +295,7 @@ establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentComma
     sequenceA $
       makeAbsolute
         <$> Setup.flagToMaybe projectConfigStoreDir
+
   cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
 
   let buildSettings =

diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -709,9 +709,7 @@ rebuildInstallPlan
           where
             corePackageDbs :: [PackageDB]
             corePackageDbs =
-              applyPackageDbFlags
-                [GlobalPackageDB]
-                (projectConfigPackageDBs projectConfigShared)
+              Cabal.interpretPackageDbFlags False (projectConfigPackageDBs projectConfigShared)
 
             withRepoCtx :: (RepoContext -> IO a) -> IO a
             withRepoCtx =
@@ -1177,13 +1175,6 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do
     hashesFromRepoMetadata
       <> hashesFromTarballFiles
 
--- | Append the given package databases to an existing PackageDBStack.
--- A @Nothing@ entry will clear everything before it.
-applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack
-applyPackageDbFlags dbs' [] = dbs'
-applyPackageDbFlags _ (Nothing : dbs) = applyPackageDbFlags [] dbs
-applyPackageDbFlags dbs' (Just db : dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs
-
 -- ------------------------------------------------------------
 
 -- * Installation planning
@@ -2321,10 +2312,7 @@ elaborateInstallPlan
         corePackageDbs
           ++ [distPackageDB (compilerId compiler)]
 
-      corePackageDbs =
-        applyPackageDbFlags
-          (storePackageDBStack compiler)
-          (projectConfigPackageDBs sharedPackageConfig)
+      corePackageDbs = storePackageDBStack compiler (projectConfigPackageDBs sharedPackageConfig)
 
       -- For this local build policy, every package that lives in a local source
       -- dir (as opposed to a tarball), or depends on such a package, will be

diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/cabal.test.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/cabal.test.hs
@@ -0,0 +1,11 @@
+import Test.Cabal.Prelude
+main = cabalTest $ do
+    recordMode DoNotRecord $ withRepo "repo" $ withPackageDb $ do
+        withDirectory "p1" $
+            setup_install []
+
+        env <- getTestEnv
+        let pkgDbPath = testPackageDbDir env
+
+        withDirectory "p2" $ do
+            void $ cabal' "v2-build" ["--package-db=" ++ pkgDbPath]
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p1
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/p1.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/p1.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p1
+version:         0.1.0.0
+license:         NONE
+author:          matthewtpickering@gmail.com
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p1/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/p1/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p2
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/cabal.project b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/p2.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/p2.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p2
+version:         0.1.0.0
+license:         NONE
+author:          matthewtpickering@gmail.com
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base, p1, p3
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/p2/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/p2/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/CHANGELOG.md b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for p1
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/p3.cabal b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/p3.cabal
@@ -0,0 +1,18 @@
+cabal-version:   3.0
+name:            p3
+version:         0.1.0.0
+license:         NONE
+author:          matthewtpickering@gmail.com
+maintainer:      Matthew Pickering
+build-type:      Simple
+extra-doc-files: CHANGELOG.md
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  MyLib
+    build-depends:    base
+    hs-source-dirs:   src
+    default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/src/MyLib.hs b/cabal-testsuite/PackageTests/PackageDB/t9678/repo/p3-0.1.0.0/src/MyLib.hs
@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"
diff --git a/changelog.d/issue-9678 b/changelog.d/issue-9678
@@ -0,0 +1,16 @@
+synopsis: Clarify the semantics of the -package-db flag
+packages: cabal-install
+prs:
+issues: #9678
+
+description: {
+
+The `--package-db` flag now only applies to the default
+immutable initial package stack rather than also applying to the store
+package database.
+
+This fixes an assertion failure which was triggered when using -package-db and also
+clarifies how it should interact with `--store-dir` and `--dist-dir` flags.
+
+}
+
diff --git a/doc/cabal-project-description-file.rst b/doc/cabal-project-description-file.rst
@@ -372,6 +372,11 @@ package, and thus apply globally:
     :synopsis: PackageDB stack manipulation
     :since: 3.7
 
+    By modifying ``package-dbs`` you can modify the default package environment
+    which ``cabal`` will see. The package databases you add using ``package-dbs``
+    will not be written into and only used as immutable package stores to initialise
+    the environment with additional packages that ``cabal`` can choose to use.
+
     There are three package databases involved with most builds:
 
     global
@@ -381,37 +386,42 @@ package, and thus apply globally:
     in-place
         Project-specific build directory
 
-    By default, the package stack you will have with v2 commands is:
+    By default, the initial package stack prefix you will have with v2 commands is:
 
     ::
 
-        -- [global, store]
+        -- prefix = [global]
 
-    So all remote packages required by your project will be
-    registered in the store package db (because it is last).
+    So the initial set of packages which is used by cabal is just the packages
+    installed in the global package database which comes with ``ghc``.
 
-    When cabal starts building your local projects, it appends the in-place db
-    to the end:
+    When cabal builds a package it will start populating the ``store`` package database,
+    whose packages will then be subsequently be available to be used in future runs.
 
     ::
 
-        -- [global, store, in-place]
+        -- prefix ++ [store]
+
+    When cabal builds your local projects, packages are registered into the local
+    in-place package database.
+
+    ::
 
-    So your local packages get put in ``dist-newstyle`` instead of the store.
+        -- prefix ++ [store, in-place]
 
-    This flag manipulates the default prefix: ``[global, store]`` and accepts
+    This flag manipulates the default prefix: ``[global]`` and accepts
     paths, the special value ``global`` referring to the global package db, and
     ``clear`` which removes all prior entries. For example,
 
     ::
 
-        -- [global, store, foo]
+        -- prefix = [global, foo]
         package-dbs: foo
 
-        -- [foo]
+        -- prefix = [foo]
         package-dbs: clear, foo
 
-        -- [bar, baz]
+        -- prefix = [bar, baz]
         package-dbs: clear, foo, clear, bar, baz
 
     The command line variant of this flag is ``--package-db=DB`` which can be