[ghc-pkg] Fix #5442 by using the flag db stack to modify packages.

Summary:
Previously, the full database stack was used for ghc-pkg to
modify packages, which meant that commands like
'ghc-pkg unregister --user' worked the same as 'ghc-pkg unregister'.
Since package modification is a "read and write" operation, we
should use the flag db stack (which is currently used for reads)
to determine which database to update.

There is also a new flag --user-package-db, which lets you explicitly
set the user database (as seen by --user).  This was mostly added
to aid in testing, but could be useful for end users as well.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonmar, hvr, austin

Subscribers: simonmar, relrod, carter

Differential Revision: https://phabricator.haskell.org/D84

12 files changed, 141 insertions, 14 deletions

diff --git a/docs/users_guide/7.10.1-notes.xml b/docs/users_guide/7.10.1-notes.xml
index 6d9b9378a1..8d0545ebf3 100644
--- a/docs/users_guide/7.10.1-notes.xml
+++ b/docs/users_guide/7.10.1-notes.xml
@@ -99,7 +99,21 @@
         <itemizedlist>
             <listitem>
                 <para>
-                    TODO FIXME
+                    <literal>ghc-pkg</literal> now respects <option>--user</option>
+                    and <option>--global</option> when modifying packages (e.g.
+                    changing exposed/trust flag or unregistering).  Previously,
+                    <literal>ghc-pkg</literal> would ignore these flags and modify
+                    whichever package it found first on the database stack.  To
+                    recover the old behavior, simply omit these flags.
+               </para>
+           </listitem>
+            <listitem>
+                <para>
+                    <literal>ghc-pkg</literal> accepts a <option>--user-package-db</option>
+                    flag which allows a user to override the location of the user package
+                    database.  Unlike databases specified using <option>--package-db</option>,
+                    a user package database configured this way respects
+                    the <option>--user</option> flag.
                </para>
            </listitem>
        </itemizedlist>
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index efb9c1c204..0d86770ac8 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -112,7 +112,7 @@ mk/ghcconfig_*_inplace_bin_ghc-stage2.exe.mk
 /tests/cabal/localT1750.package.conf/
 /tests/cabal/localshadow1.package.conf/
 /tests/cabal/localshadow2.package.conf/
-/tests/cabal/package.conf.ghcpkg02/
+/tests/cabal/package.conf.*/
 /tests/cabal/shadow.hs
 /tests/cabal/shadow1.out
 /tests/cabal/shadow2.out
diff --git a/testsuite/tests/cabal/Makefile b/testsuite/tests/cabal/Makefile
index f0091bceeb..e8ed2bd817 100644
--- a/testsuite/tests/cabal/Makefile
+++ b/testsuite/tests/cabal/Makefile
@@ -165,6 +165,60 @@ shadow:
 	@echo "should SUCCEED:"
 	'$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONFSHADOW1) -package-db $(PKGCONFSHADOW2) -package-id shadowdep-1-XXX -c shadow.hs -fno-code
 
+# If we pass --global, we should ignore instances in the user database
+T5442a:
+	@rm -rf package.conf.T5442a.global package.conf.T5442a.user
+	'$(GHC_PKG)' init package.conf.T5442a.global
+	'$(GHC_PKG)' init package.conf.T5442a.user
+	'$(GHC_PKG)' -f package.conf.T5442a.global register --force-files test.pkg 2>/dev/null
+	'$(GHC_PKG)' -f package.conf.T5442a.user register --force-files test.pkg 2>/dev/null
+	'$(GHC_PKG)' --global-package-db=package.conf.T5442a.global --user-package-db=package.conf.T5442a.user --global unregister testpkg
+	@echo "global (should be empty):"
+	'$(GHC_PKG)' -f package.conf.T5442a.global list --simple-output
+	@echo "user:"
+	'$(GHC_PKG)' -f package.conf.T5442a.user list --simple-output
+
+# If we pass --user, we should ignore instances in the global database
+T5442b:
+	@rm -rf package.conf.T5442b.global package.conf.T5442b.user
+	'$(GHC_PKG)' init package.conf.T5442b.global
+	'$(GHC_PKG)' init package.conf.T5442b.user
+	'$(GHC_PKG)' -f package.conf.T5442b.global register --force-files test.pkg 2>/dev/null
+	! '$(GHC_PKG)' --global-package-db=package.conf.T5442b.global --user-package-db=package.conf.T5442b.user --user unregister testpkg
+	@echo "global (should have testpkg):"
+	'$(GHC_PKG)' -f package.conf.T5442b.global list --simple-output
+
+# If we pass -f, we should ignore the user and global databases
+T5442c:
+	@rm -rf package.conf.T5442c.global package.conf.T5442c.user package.conf.T5442c.extra
+	'$(GHC_PKG)' init package.conf.T5442c.global
+	'$(GHC_PKG)' init package.conf.T5442c.user
+	'$(GHC_PKG)' init package.conf.T5442c.extra
+	'$(GHC_PKG)' -f package.conf.T5442c.global register --force-files test.pkg 2>/dev/null
+	'$(GHC_PKG)' -f package.conf.T5442c.user register --force-files test.pkg 2>/dev/null
+	! '$(GHC_PKG)' --global-package-db=package.conf.T5442c.global --user-package-db=package.conf.T5442c.user -f package.conf.T5442c.extra unregister testpkg
+	@echo "global (should have testpkg):"
+	'$(GHC_PKG)' -f package.conf.T5442c.global list --simple-output
+	@echo "use (should have testpkg):"
+	'$(GHC_PKG)' -f package.conf.T5442c.user list --simple-output
+
+# If we pass --global and -f, we remove from the global database, but
+# warn about possible breakage in the full package stack
+T5442d:
+	@rm -rf package.conf.T5442d.global package.conf.T5442d.user package.conf.T5442d.extra
+	'$(GHC_PKG)' init package.conf.T5442d.global
+	'$(GHC_PKG)' init package.conf.T5442d.user
+	'$(GHC_PKG)' init package.conf.T5442d.extra
+	'$(GHC_PKG)' -f package.conf.T5442d.global register --force-files shadow1.pkg 2>/dev/null
+	'$(GHC_PKG)' -f package.conf.T5442d.user register --force-files shadow3.pkg 2>/dev/null
+	'$(GHC_PKG)' --global-package-db=package.conf.T5442d.global -f package.conf.T5442d.extra register --force-files shadow2.pkg 2>/dev/null
+	'$(GHC_PKG)' --global-package-db=package.conf.T5442d.global --user-package-db=package.conf.T5442d.user -f package.conf.T5442d.extra --global unregister shadow --force
+	@echo "global (should be empty):"
+	'$(GHC_PKG)' -f package.conf.T5442d.global list --simple-output
+	@echo "user:"
+	'$(GHC_PKG)' -f package.conf.T5442d.user list --simple-output
+	@echo "extra:"
+	'$(GHC_PKG)' -f package.conf.T5442d.extra list --simple-output
 
 # -----------------------------------------------------------------------------
 # Try piping the output of "ghc-pkg describe" into "ghc-pkg update" for
diff --git a/testsuite/tests/cabal/T5442a.stdout b/testsuite/tests/cabal/T5442a.stdout
new file mode 100644
index 0000000000..7bc64650e0
--- /dev/null
+++ b/testsuite/tests/cabal/T5442a.stdout
@@ -0,0 +1,5 @@
+Reading package info from "test.pkg" ... done.
+Reading package info from "test.pkg" ... done.
+global (should be empty):
+user:
+testpkg-1.2.3.4
diff --git a/testsuite/tests/cabal/T5442b.stderr b/testsuite/tests/cabal/T5442b.stderr
new file mode 100644
index 0000000000..da7439820d
--- /dev/null
+++ b/testsuite/tests/cabal/T5442b.stderr
@@ -0,0 +1 @@
+ghc-pkg: cannot find package testpkg
diff --git a/testsuite/tests/cabal/T5442b.stdout b/testsuite/tests/cabal/T5442b.stdout
new file mode 100644
index 0000000000..42814de517
--- /dev/null
+++ b/testsuite/tests/cabal/T5442b.stdout
@@ -0,0 +1,3 @@
+Reading package info from "test.pkg" ... done.
+global (should have testpkg):
+testpkg-1.2.3.4
diff --git a/testsuite/tests/cabal/T5442c.stderr b/testsuite/tests/cabal/T5442c.stderr
new file mode 100644
index 0000000000..da7439820d
--- /dev/null
+++ b/testsuite/tests/cabal/T5442c.stderr
@@ -0,0 +1 @@
+ghc-pkg: cannot find package testpkg
diff --git a/testsuite/tests/cabal/T5442c.stdout b/testsuite/tests/cabal/T5442c.stdout
new file mode 100644
index 0000000000..a183e595ba
--- /dev/null
+++ b/testsuite/tests/cabal/T5442c.stdout
@@ -0,0 +1,6 @@
+Reading package info from "test.pkg" ... done.
+Reading package info from "test.pkg" ... done.
+global (should have testpkg):
+testpkg-1.2.3.4
+use (should have testpkg):
+testpkg-1.2.3.4
diff --git a/testsuite/tests/cabal/T5442d.stderr b/testsuite/tests/cabal/T5442d.stderr
new file mode 100644
index 0000000000..ae02fa783f
--- /dev/null
+++ b/testsuite/tests/cabal/T5442d.stderr
@@ -0,0 +1 @@
+unregistering shadow would break the following packages: shadowdep-1 (ignoring)
diff --git a/testsuite/tests/cabal/T5442d.stdout b/testsuite/tests/cabal/T5442d.stdout
new file mode 100644
index 0000000000..05c6619dde
--- /dev/null
+++ b/testsuite/tests/cabal/T5442d.stdout
@@ -0,0 +1,8 @@
+Reading package info from "shadow1.pkg" ... done.
+Reading package info from "shadow3.pkg" ... done.
+Reading package info from "shadow2.pkg" ... done.
+global (should be empty):
+user:
+shadow-1
+extra:
+shadowdep-1
diff --git a/testsuite/tests/cabal/all.T b/testsuite/tests/cabal/all.T
index d05d05fe1e..aa97f48209 100644
--- a/testsuite/tests/cabal/all.T
+++ b/testsuite/tests/cabal/all.T
@@ -57,6 +57,28 @@ test('T1750',
                   'localT1750.package.conf.old']),
      run_command, ['$MAKE -s --no-print-directory T1750'])
 
+test('T5442a',
+     [extra_clean(['package.conf.T5442a.global', 'package.conf.T5442a.user'])],
+     run_command,
+     ['$MAKE -s --no-print-directory T5442a'])
+
+test('T5442b',
+     [extra_clean(['package.conf.T5442b.global', 'package.conf.T5442b.user'])],
+     run_command,
+     ['$MAKE -s --no-print-directory T5442b'])
+
+test('T5442c',
+     [extra_clean(['package.conf.T5442c.global', 'package.conf.T5442c.user',
+                   'package.conf.T5442c.extra'])],
+     run_command,
+     ['$MAKE -s --no-print-directory T5442c'])
+
+test('T5442d',
+     [extra_clean(['package.conf.T5442d.global', 'package.conf.T5442d.user',
+                   'package.conf.T5442d.extra'])],
+     run_command,
+     ['$MAKE -s --no-print-directory T5442d'])
+
 test('shadow',
      extra_clean(['shadow.out', 'shadow.hs', 'shadow.hi',
                   'local1shadow1.package.conf',
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index e51755ce2c..390873a87b 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -111,6 +111,7 @@ data Flag
   | FlagVersion
   | FlagConfig FilePath
   | FlagGlobalConfig FilePath
+  | FlagUserConfig FilePath
   | FlagForce
   | FlagForceFiles
   | FlagAutoGHCiLibs
@@ -139,6 +140,8 @@ flags = [
         "location of the global package database",
   Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
         "never read the user package database",
+  Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR")
+        "location of the user package database (use instead of default)",
   Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
         "never read the user package database (DEPRECATED)",
   Option [] ["force"] (NoArg FlagForce)
@@ -521,16 +524,18 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
   e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
 
   mb_user_conf <-
-     if no_user_db then return Nothing else
-     case e_appdir of
-       Left _    -> return Nothing
-       Right appdir -> do
-         let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
-             dir = appdir </> subdir
-         r <- lookForPackageDBIn dir
-         case r of
-           Nothing -> return (Just (dir </> "package.conf.d", False))
-           Just f  -> return (Just (f, True))
+    case [ f | FlagUserConfig f <- my_flags ] of
+      _ | no_user_db -> return Nothing
+      [] -> case e_appdir of
+        Left _    -> return Nothing
+        Right appdir -> do
+          let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
+              dir = appdir </> subdir
+          r <- lookForPackageDBIn dir
+          case r of
+            Nothing -> return (Just (dir </> "package.conf.d", False))
+            Just f  -> return (Just (f, True))
+      fs -> return (Just (last fs, True))
 
   -- If the user database doesn't exist, and this command isn't a
   -- "modify" command, then we won't attempt to create or use it.
@@ -591,6 +596,11 @@ getPkgDatabases verbosity modify use_cache expand_vars my_flags = do
   let flag_db_stack = [ db | db_name <- flag_db_names,
                         db <- db_stack, location db == db_name ]
 
+  when (verbosity > Normal) $ do
+    infoLn ("db stack: " ++ show (map location db_stack))
+    infoLn ("modifying: " ++ show to_modify)
+    infoLn ("flag db stack: " ++ show (map location flag_db_stack))
+
   return (db_stack, to_modify, flag_db_stack)
 
 
@@ -948,10 +958,11 @@ modifyPackage
   -> Force
   -> IO ()
 modifyPackage fn pkgid verbosity my_flags force = do
-  (db_stack, Just _to_modify, _flag_dbs) <- 
+  (db_stack, Just _to_modify, flag_dbs) <-
       getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags
 
-  (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
+  -- Do the search for the package respecting flags...
+  (db, ps) <- fmap head $ findPackagesByDB flag_dbs (Id pkgid)
   let 
       db_name = location db
       pkgs    = packages db
@@ -961,6 +972,7 @@ modifyPackage fn pkgid verbosity my_flags force = do
       cmds = [ fn pkg | pkg <- pkgs, sourcePackageId pkg `elem` pids ]
       new_db = updateInternalDB db cmds
 
+      -- ...but do consistency checks with regards to the full stack
       old_broken = brokenPackages (allPackagesInStack db_stack)
       rest_of_stack = filter ((/= db_name) . location) db_stack
       new_stack = new_db : rest_of_stack