Add support for concurrent package db access and updates

Trac issues: #13194

Reviewers: austin, hvr, erikd, bgamari, dfeuer, duncan

Subscribers: DemiMarie, dfeuer, thomie

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

1 files changed, 259 insertions, 131 deletions

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 3355838477..44960ca0b6 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -1,7 +1,13 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 --
@@ -53,6 +59,8 @@ import System.IO.Error
 import GHC.IO.Exception (IOErrorType(InappropriateType))
 import Data.List
 import Control.Concurrent
+import qualified Data.Foldable as F
+import qualified Data.Traversable as F
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -527,7 +535,7 @@ readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
 -- Some commands operate  on multiple databases, with overlapping semantics:
 --      list, describe, field
 
-data PackageDB
+data PackageDB (mode :: GhcPkg.DbMode)
   = PackageDB {
       location, locationAbsolute :: !FilePath,
       -- We need both possibly-relative and definitely-absolute package
@@ -536,18 +544,27 @@ data PackageDB
       -- On the other hand we need the absolute path in a few places
       -- particularly in relation to the ${pkgroot} stuff.
 
+      packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock),
+      -- If package db is open in read write mode, we keep its lock around for
+      -- transactional updates.
+
       packages :: [InstalledPackageInfo]
     }
 
-type PackageDBStack = [PackageDB]
+type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly]
         -- A stack of package databases.  Convention: head is the topmost
         -- in the stack.
 
+-- | Selector for picking the right package DB to modify as 'register' and
+-- 'recache' operate on the database on top of the stack, whereas 'modify'
+-- changes the first database that contains a specific package.
+data DbModifySelector = TopOne | ContainsPkg PackageArg
+
 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
 allPackagesInStack = concatMap packages
 
 getPkgDatabases :: Verbosity
-                -> Bool    -- we are modifying, not reading
+                -> GhcPkg.DbOpenMode mode DbModifySelector
                 -> Bool    -- use the user db
                 -> Bool    -- read caches, if available
                 -> Bool    -- expand vars, like ${pkgroot} and $topdir
@@ -555,7 +572,7 @@ getPkgDatabases :: Verbosity
                 -> IO (PackageDBStack,
                           -- the real package DB stack: [global,user] ++
                           -- DBs specified on the command line with -f.
-                       Maybe FilePath,
+                       GhcPkg.DbOpenMode mode (PackageDB mode),
                           -- which one to modify, if any
                        PackageDBStack)
                           -- the package DBs specified on the command
@@ -563,7 +580,7 @@ getPkgDatabases :: Verbosity
                           -- is used as the list of package DBs for
                           -- commands that just read the DB, such as 'list'.
 
-getPkgDatabases verbosity modify use_user use_cache expand_vars my_flags = do
+getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
   -- first we determine the location of the global package config.  On Windows,
   -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
   -- location is passed to the binary using the --global-package-db flag by the
@@ -652,29 +669,117 @@ getPkgDatabases verbosity modify use_user use_cache expand_vars my_flags = do
                      [ f | FlagConfig f <- reverse my_flags ]
                      ++ env_stack
 
-  -- the database we actually modify is the one mentioned
-  -- rightmost on the command-line.
-  let to_modify
-        | not modify    = Nothing
-        | null db_flags = Just virt_global_conf
-        | otherwise     = Just (last db_flags)
+      top_db = if null db_flags
+               then virt_global_conf
+               else last db_flags
 
-  db_stack  <- sequence
-    [ do db <- readParseDatabase verbosity mb_user_conf modify use_cache db_path
-         if expand_vars then return (mungePackageDBPaths top_dir db)
-                        else return db
-    | db_path <- final_stack ]
+  (db_stack, db_to_operate_on) <- getDatabases top_dir mb_user_conf
+                                               flag_db_names final_stack top_db
 
   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)
+    F.forM_ db_to_operate_on $ \db ->
+      infoLn ("modifying: " ++ (location db))
     infoLn ("flag db stack: " ++ show (map location flag_db_stack))
 
-  return (db_stack, to_modify, flag_db_stack)
-
+  return (db_stack, db_to_operate_on, flag_db_stack)
+  where
+    getDatabases top_dir mb_user_conf flag_db_names
+                 final_stack top_db = case mode of
+      -- When we open in read only mode, we simply read all of the databases/
+      GhcPkg.DbOpenReadOnly -> do
+        db_stack <- mapM readDatabase final_stack
+        return (db_stack, GhcPkg.DbOpenReadOnly)
+
+      -- The only package db we open in read write mode is the one on the top of
+      -- the stack.
+      GhcPkg.DbOpenReadWrite TopOne -> do
+        (db_stack, mto_modify) <- stateSequence Nothing
+          [ \case
+              to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
+              Nothing -> if db_path /= top_db
+                then (, Nothing) <$> readDatabase db_path
+                else do
+                  db <- readParseDatabase verbosity mb_user_conf
+                                          mode use_cache db_path
+                    `Exception.catch` couldntOpenDbForModification db_path
+                  let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
+                  return (ro_db, Just db)
+          | db_path <- final_stack ]
+
+        to_modify <- case mto_modify of
+          Just db -> return db
+          Nothing -> die "no database selected for modification"
+
+        return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
+
+      -- The package db we open in read write mode is the first one included in
+      -- flag_db_names that contains specified package. Therefore we need to
+      -- open each one in read/write mode first and decide whether it's for
+      -- modification based on its contents.
+      GhcPkg.DbOpenReadWrite (ContainsPkg pkgarg) -> do
+        (db_stack, mto_modify) <- stateSequence Nothing
+          [ \case
+              to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
+              Nothing -> if db_path `notElem` flag_db_names
+                then (, Nothing) <$> readDatabase db_path
+                else do
+                  let hasPkg :: PackageDB mode -> Bool
+                      hasPkg = not . null . findPackage pkgarg . packages
+
+                      openRo (e::IOError) = do
+                        db <- readDatabase db_path
+                        if hasPkg db
+                          then couldntOpenDbForModification db_path e
+                          else return (db, Nothing)
+
+                  -- If we fail to open the database in read/write mode, we need
+                  -- to check if it's for modification first before throwing an
+                  -- error, so we attempt to open it in read only mode.
+                  Exception.handle openRo $ do
+                    db <- readParseDatabase verbosity mb_user_conf
+                                            mode use_cache db_path
+                    let ro_db = db { packageDbLock = GhcPkg.DbOpenReadOnly }
+                    if hasPkg db
+                      then return (ro_db, Just db)
+                      else do
+                        -- If the database is not for modification after all,
+                        -- drop the write lock as we are already finished with
+                        -- the database.
+                        case packageDbLock db of
+                          GhcPkg.DbOpenReadWrite lock ->
+                            GhcPkg.unlockPackageDb lock
+                        return (ro_db, Nothing)
+          | db_path <- final_stack ]
+
+        to_modify <- case mto_modify of
+          Just db -> return db
+          Nothing -> cannotFindPackage pkgarg Nothing
+
+        return (db_stack, GhcPkg.DbOpenReadWrite to_modify)
+      where
+        couldntOpenDbForModification :: FilePath -> IOError -> IO a
+        couldntOpenDbForModification db_path e = die $ "Couldn't open database "
+          ++ db_path ++ " for modification: " ++ show e
+
+        -- Parse package db in read-only mode.
+        readDatabase :: FilePath -> IO (PackageDB 'GhcPkg.DbReadOnly)
+        readDatabase db_path = do
+          db <- readParseDatabase verbosity mb_user_conf
+                                  GhcPkg.DbOpenReadOnly use_cache db_path
+          if expand_vars
+            then return $ mungePackageDBPaths top_dir db
+            else return db
+
+    stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
+    stateSequence s []     = return ([], s)
+    stateSequence s (m:ms) = do
+      (a, s')   <- m s
+      (as, s'') <- stateSequence s' ms
+      return (a : as, s'')
 
 lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
 lookForPackageDBIn dir = do
@@ -685,17 +790,16 @@ lookForPackageDBIn dir = do
     exists_file <- doesFileExist path_file
     if exists_file then return (Just path_file) else return Nothing
 
-readParseDatabase :: Verbosity
+readParseDatabase :: forall mode t. Verbosity
                   -> Maybe (FilePath,Bool)
-                  -> Bool -- we will be modifying, not just reading
+                  -> GhcPkg.DbOpenMode mode t
                   -> Bool -- use cache
                   -> FilePath
-                  -> IO PackageDB
-
-readParseDatabase verbosity mb_user_conf modify use_cache path
+                  -> IO (PackageDB mode)
+readParseDatabase verbosity mb_user_conf mode use_cache path
   -- the user database (only) is allowed to be non-existent
   | Just (user_conf,False) <- mb_user_conf, path == user_conf
-  = mkPackageDB []
+  = mkPackageDB [] =<< F.mapM (const $ GhcPkg.lockPackageDb path) mode
   | otherwise
   = do e <- tryIO $ getDirectoryContents path
        case e of
@@ -704,7 +808,7 @@ readParseDatabase verbosity mb_user_conf modify use_cache path
               -- We provide a limited degree of backwards compatibility for
               -- old single-file style db:
               mdb <- tryReadParseOldFileStyleDatabase verbosity
-                       mb_user_conf modify use_cache path
+                       mb_user_conf mode use_cache path
               case mdb of
                 Just db -> return db
                 Nothing ->
@@ -750,8 +854,8 @@ readParseDatabase verbosity mb_user_conf modify use_cache path
                       then do
                           when (verbosity > Normal) $
                              infoLn ("using cache: " ++ cache)
-                          pkgs <- GhcPkg.readPackageDbForGhcPkg cache
-                          mkPackageDB pkgs
+                          GhcPkg.readPackageDbForGhcPkg cache mode
+                            >>= uncurry mkPackageDB
                       else do
                           whenReportCacheErrors $ do
                               warn ("WARNING: cache is out of date: " ++ cache)
@@ -759,19 +863,22 @@ readParseDatabase verbosity mb_user_conf modify use_cache path
                                     "package db. " ++ recacheAdvice)
                           ignore_cache compareTimestampToCache
             where
-                 ignore_cache :: (FilePath -> IO ()) -> IO PackageDB
+                 ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
                  ignore_cache checkTime = do
+                     -- If we're opening for modification, we need to acquire a
+                     -- lock even if we don't open the cache now, because we are
+                     -- going to modify it later.
+                     lock <- F.mapM (const $ GhcPkg.lockPackageDb path) mode
                      let confs = filter (".conf" `isSuffixOf`) fs
                          doFile f = do checkTime f
                                        parseSingletonPackageConf verbosity f
                      pkgs <- mapM doFile $ map (path </>) confs
-                     mkPackageDB pkgs
+                     mkPackageDB pkgs lock
 
                  -- We normally report cache errors for read-only commands,
-                 -- since modify commands because will usually fix the cache.
-                 whenReportCacheErrors =
-                     when (   verbosity >  Normal
-                           || verbosity >= Normal && not modify)
+                 -- since modify commands will usually fix the cache.
+                 whenReportCacheErrors = when $ verbosity > Normal
+                   || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode
   where
     recacheAdvice
       | Just (user_conf, True) <- mb_user_conf, path == user_conf
@@ -779,13 +886,17 @@ readParseDatabase verbosity mb_user_conf modify use_cache path
       | otherwise
       = "Use 'ghc-pkg recache' to fix."
 
-    mkPackageDB pkgs = do
+    mkPackageDB :: [InstalledPackageInfo]
+                -> GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock
+                -> IO (PackageDB mode)
+    mkPackageDB pkgs lock = do
       path_abs <- absolutePath path
-      return PackageDB {
-        location = path,
-        locationAbsolute = path_abs,
-        packages = pkgs
-      }
+      return $ PackageDB {
+          location = path,
+          locationAbsolute = path_abs,
+          packageDbLock = lock,
+          packages = pkgs
+        }
 
 parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
 parseSingletonPackageConf verbosity file = do
@@ -795,7 +906,7 @@ parseSingletonPackageConf verbosity file = do
 cachefilename :: FilePath
 cachefilename = "package.cache"
 
-mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB
+mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode
 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
     db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
   where
@@ -872,44 +983,48 @@ mungePackagePaths top_dir pkgroot pkg =
 -- ghc itself also cooperates in this workaround
 
 tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
-                                 -> Bool -> Bool -> FilePath
-                                 -> IO (Maybe PackageDB)
-tryReadParseOldFileStyleDatabase verbosity mb_user_conf modify use_cache path = do
+                                 -> GhcPkg.DbOpenMode mode t -> Bool -> FilePath
+                                 -> IO (Maybe (PackageDB mode))
+tryReadParseOldFileStyleDatabase verbosity mb_user_conf
+                                 mode use_cache path = do
   -- assumes we've already established that path exists and is not a dir
   content <- readFile path `catchIO` \_ -> return ""
   if take 2 content == "[]"
     then do
       path_abs <- absolutePath path
-      let path_dir = path <.> "d"
+      let path_dir = adjustOldDatabasePath path
       warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
       direxists <- doesDirectoryExist path_dir
       if direxists
-         then do db <- readParseDatabase verbosity mb_user_conf
-                                   modify use_cache path_dir
-                 -- but pretend it was at the original location
-                 return $ Just db {
-                   location         = path,
-                   locationAbsolute = path_abs
-                 }
-         else   return $ Just PackageDB {
-                   location         = path,
-                   locationAbsolute = path_abs,
-                   packages         = []
-                 }
+        then do
+          db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir
+          -- but pretend it was at the original location
+          return $ Just db {
+              location         = path,
+              locationAbsolute = path_abs
+            }
+         else do
+           lock <- F.mapM (const $ GhcPkg.lockPackageDb path_dir) mode
+           return $ Just PackageDB {
+               location         = path,
+               locationAbsolute = path_abs,
+               packageDbLock    = lock,
+               packages         = []
+             }
 
     -- if the path is not a file, or is not an empty db then we fail
     else return Nothing
 
-adjustOldFileStylePackageDB :: PackageDB -> IO PackageDB
+adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)
 adjustOldFileStylePackageDB db = do
   -- assumes we have not yet established if it's an old style or not
   mcontent <- liftM Just (readFile (location db)) `catchIO` \_ -> return Nothing
   case fmap (take 2) mcontent of
     -- it is an old style and empty db, so look for a dir kind in location.d/
     Just "[]" -> return db {
-                   location         = location db <.> "d",
-                   locationAbsolute = locationAbsolute db <.> "d"
-                 }
+        location         = adjustOldDatabasePath $ location db,
+        locationAbsolute = adjustOldDatabasePath $ locationAbsolute db
+      }
     -- it is old style but not empty, we have to bail
     Just  _   -> die $ "ghc no longer supports single-file style package "
                     ++ "databases (" ++ location db ++ ") use 'ghc-pkg init'"
@@ -917,6 +1032,8 @@ adjustOldFileStylePackageDB db = do
     -- probably not old style, carry on as normal
     Nothing   -> return db
 
+adjustOldDatabasePath :: FilePath -> FilePath
+adjustOldDatabasePath = (<.> "d")
 
 -- -----------------------------------------------------------------------------
 -- Creating a new package DB
@@ -928,11 +1045,15 @@ initPackageDB filename verbosity _flags = do
   when b1 eexist
   b2 <- doesDirectoryExist filename
   when b2 eexist
+  createDirectoryIfMissing True filename
+  lock <- GhcPkg.lockPackageDb $ filename </> cachefilename
   filename_abs <- absolutePath filename
   changeDB verbosity [] PackageDB {
-                          location = filename, locationAbsolute = filename_abs,
-                          packages = []
-                        }
+      location = filename,
+      locationAbsolute = filename_abs,
+      packageDbLock = GhcPkg.DbOpenReadWrite lock,
+      packages = []
+    }
 
 -- -----------------------------------------------------------------------------
 -- Registering
@@ -947,13 +1068,12 @@ registerPackage :: FilePath
                 -> IO ()
 registerPackage input verbosity my_flags multi_instance
                 expand_env_vars update force = do
-  (db_stack, Just to_modify, _flag_dbs) <-
-      getPkgDatabases verbosity True{-modify-} True{-use user-}
-                                True{-use cache-} False{-expand vars-} my_flags
+  (db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <-
+    getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne)
+      True{-use user-} True{-use cache-} False{-expand vars-} my_flags
+
+  let to_modify = location db_to_operate_on
 
-  let
-        db_to_operate_on = my_head "register" $
-                           filter ((== to_modify).location) db_stack
   s <-
     case input of
       "-" -> do
@@ -1026,14 +1146,15 @@ data DBOp = RemovePackage InstalledPackageInfo
           | AddPackage    InstalledPackageInfo
           | ModifyPackage InstalledPackageInfo
 
-changeDB :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDB :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
 changeDB verbosity cmds db = do
   let db' = updateInternalDB db cmds
   db'' <- adjustOldFileStylePackageDB db'
   createDirectoryIfMissing True (location db'')
   changeDBDir verbosity cmds db''
 
-updateInternalDB :: PackageDB -> [DBOp] -> PackageDB
+updateInternalDB :: PackageDB 'GhcPkg.DbReadWrite
+                 -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite
 updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
  where
   do_cmd pkgs (RemovePackage p) =
@@ -1043,7 +1164,7 @@ updateInternalDB db cmds = db{ packages = foldl do_cmd (packages db) cmds }
     do_cmd (do_cmd pkgs (RemovePackage p)) (AddPackage p)
 
 
-changeDBDir :: Verbosity -> [DBOp] -> PackageDB -> IO ()
+changeDBDir :: Verbosity -> [DBOp] -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
 changeDBDir verbosity cmds db = do
   mapM_ do_cmd cmds
   updateDBCache verbosity db
@@ -1059,7 +1180,7 @@ changeDBDir verbosity cmds db = do
   do_cmd (ModifyPackage p) =
     do_cmd (AddPackage p)
 
-updateDBCache :: Verbosity -> PackageDB -> IO ()
+updateDBCache :: Verbosity -> PackageDB 'GhcPkg.DbReadWrite -> IO ()
 updateDBCache verbosity db = do
   let filename = location db </> cachefilename
 
@@ -1071,20 +1192,25 @@ updateDBCache verbosity db = do
 
   when (verbosity > Normal) $
       infoLn ("writing cache " ++ filename)
+
   GhcPkg.writePackageDb filename pkgsGhcCacheFormat pkgsCabalFormat
     `catchIO` \e ->
       if isPermissionError e
-      then die (filename ++ ": you don't have permission to modify this file")
+      then die $ filename ++ ": you don't have permission to modify this file"
       else ioError e
+
   -- See Note [writeAtomic leaky abstraction]
-  -- Cross-platform "touch". This only works if filename is not empty, and not
-  -- open for writing already.
+  -- Cross-platform "touch". This only works if filename is not empty, and
+  -- not open for writing already.
   -- TODO. When the Win32 or directory packages have either a touchFile or a
   -- setModificationTime function, use one of those.
   withBinaryFile filename ReadWriteMode $ \handle -> do
-      c <- hGetChar handle
-      hSeek handle AbsoluteSeek 0
-      hPutChar handle c
+    c <- hGetChar handle
+    hSeek handle AbsoluteSeek 0
+    hPutChar handle c
+
+  case packageDbLock db of
+    GhcPkg.DbOpenReadWrite lock -> GhcPkg.unlockPackageDb lock
 
 type PackageCacheFormat = GhcPkg.InstalledPackageInfo
                             ComponentId
@@ -1192,25 +1318,29 @@ modifyPackage
   -> Force
   -> IO ()
 modifyPackage fn pkgarg verbosity my_flags force = do
-  (db_stack, Just _to_modify, flag_dbs) <-
-      getPkgDatabases verbosity True{-modify-} True{-use user-}
-                                True{-use cache-} False{-expand vars-} my_flags
+  (db_stack, GhcPkg.DbOpenReadWrite db, _flag_dbs) <-
+    getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite $ ContainsPkg pkgarg)
+      True{-use user-} True{-use cache-} False{-expand vars-} my_flags
 
-  -- Do the search for the package respecting flags...
-  (db, ps) <- fmap head $ findPackagesByDB flag_dbs pkgarg
-  let
-      db_name = location db
+  let db_name = location db
       pkgs    = packages db
 
-      pks = map installedUnitId ps
+      -- Get package respecting flags...
+      ps = findPackage pkgarg pkgs
+
+  -- This shouldn't happen if getPkgDatabases picks the DB correctly.
+  when (null ps) $ cannotFindPackage pkgarg $ Just db
+
+  let pks = map installedUnitId ps
 
       cmds = [ fn pkg | pkg <- pkgs, installedUnitId pkg `elem` pks ]
       new_db = updateInternalDB db cmds
+      new_db_ro = new_db { packageDbLock = GhcPkg.DbOpenReadOnly }
 
       -- ...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
+      new_stack = new_db_ro : rest_of_stack
       new_broken = brokenPackages (allPackagesInStack new_stack)
       newly_broken = filter ((`notElem` map installedUnitId old_broken)
                             . installedUnitId) new_broken
@@ -1229,13 +1359,9 @@ modifyPackage fn pkgarg verbosity my_flags force = do
 
 recache :: Verbosity -> [Flag] -> IO ()
 recache verbosity my_flags = do
-  (db_stack, Just to_modify, _flag_dbs) <-
-     getPkgDatabases verbosity True{-modify-} True{-use user-} False{-no cache-}
-                               False{-expand vars-} my_flags
-  let
-        db_to_operate_on = my_head "recache" $
-                           filter ((== to_modify).location) db_stack
-  --
+  (_db_stack, GhcPkg.DbOpenReadWrite db_to_operate_on, _flag_dbs) <-
+    getPkgDatabases verbosity (GhcPkg.DbOpenReadWrite TopOne)
+      True{-use user-} False{-no cache-} False{-expand vars-} my_flags
   changeDB verbosity [] db_to_operate_on
 
 -- -----------------------------------------------------------------------------
@@ -1246,9 +1372,9 @@ listPackages ::  Verbosity -> [Flag] -> Maybe PackageArg
              -> IO ()
 listPackages verbosity my_flags mPackageName mModuleName = do
   let simple_output = FlagSimpleOutput `elem` my_flags
-  (db_stack, _, flag_db_stack) <-
-     getPkgDatabases verbosity False{-modify-} False{-use user-}
-                               True{-use cache-} False{-expand vars-} my_flags
+  (db_stack, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} False{-expand vars-} my_flags
 
   let db_stack_filtered -- if a package is given, filter out all other packages
         | Just this <- mPackageName =
@@ -1346,9 +1472,9 @@ simplePackageList my_flags pkgs = do
 
 showPackageDot :: Verbosity -> [Flag] -> IO ()
 showPackageDot verbosity myflags = do
-  (_, _, flag_db_stack) <-
-      getPkgDatabases verbosity False{-modify-} False{-use user-}
-                                True{-use cache-} False{-expand vars-} myflags
+  (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} False{-expand vars-} myflags
 
   let all_pkgs = allPackagesInStack flag_db_stack
       ipix  = PackageIndex.fromList all_pkgs
@@ -1371,9 +1497,9 @@ showPackageDot verbosity myflags = do
 -- dependencies may be varying versions
 latestPackage ::  Verbosity -> [Flag] -> GlobPackageIdentifier -> IO ()
 latestPackage verbosity my_flags pkgid = do
-  (_, _, flag_db_stack) <-
-     getPkgDatabases verbosity False{-modify-} False{-use user-}
-                               True{-use cache-} False{-expand vars-} my_flags
+  (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} False{-expand vars-} my_flags
 
   ps <- findPackages flag_db_stack (Id pkgid)
   case ps of
@@ -1387,18 +1513,18 @@ latestPackage verbosity my_flags pkgid = do
 
 describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO ()
 describePackage verbosity my_flags pkgarg expand_pkgroot = do
-  (_, _, flag_db_stack) <-
-      getPkgDatabases verbosity False{-modify-} False{-use user-}
-                                True{-use cache-} expand_pkgroot my_flags
+  (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} expand_pkgroot my_flags
   dbs <- findPackagesByDB flag_db_stack pkgarg
   doDump expand_pkgroot [ (pkg, locationAbsolute db)
                         | (db, pkgs) <- dbs, pkg <- pkgs ]
 
 dumpPackages :: Verbosity -> [Flag] -> Bool -> IO ()
 dumpPackages verbosity my_flags expand_pkgroot = do
-  (_, _, flag_db_stack) <-
-     getPkgDatabases verbosity False{-modify-} False{-use user-}
-                               True{-use cache-} expand_pkgroot my_flags
+  (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} expand_pkgroot my_flags
   doDump expand_pkgroot [ (pkg, locationAbsolute db)
                         | db <- flag_db_stack, pkg <- packages db ]
 
@@ -1420,19 +1546,26 @@ findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 findPackages db_stack pkgarg
   = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
 
+findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
+findPackage pkgarg pkgs = filter (pkgarg `matchesPkg`) pkgs
+
 findPackagesByDB :: PackageDBStack -> PackageArg
-                 -> IO [(PackageDB, [InstalledPackageInfo])]
+                 -> IO [(PackageDB 'GhcPkg.DbReadOnly, [InstalledPackageInfo])]
 findPackagesByDB db_stack pkgarg
   = case [ (db, matched)
          | db <- db_stack,
-           let matched = filter (pkgarg `matchesPkg`) (packages db),
+           let matched = findPackage pkgarg $ packages db,
            not (null matched) ] of
-        [] -> die ("cannot find package " ++ pkg_msg pkgarg)
+        [] -> cannotFindPackage pkgarg Nothing
         ps -> return ps
+
+cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a
+cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg
+  ++ maybe "" (\db -> " in " ++ location db) mdb
   where
-        pkg_msg (Id pkgid)           = displayGlobPkgId pkgid
-        pkg_msg (IUId ipid)          = display ipid
-        pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
+    pkg_msg (Id pkgid)           = displayGlobPkgId pkgid
+    pkg_msg (IUId ipid)          = display ipid
+    pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
 
 matches :: GlobPackageIdentifier -> PackageIdentifier -> Bool
 GlobPackageIdentifier pn `matches` pid'
@@ -1451,9 +1584,9 @@ matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
 
 describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO ()
 describeField verbosity my_flags pkgarg fields expand_pkgroot = do
-  (_, _, flag_db_stack) <-
-      getPkgDatabases verbosity False{-modify-} False{-use user-}
-                                True{-use cache-} expand_pkgroot my_flags
+  (_, GhcPkg.DbOpenReadOnly, flag_db_stack) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      False{-use user-} True{-use cache-} expand_pkgroot my_flags
   fns <- mapM toField fields
   ps <- findPackages flag_db_stack pkgarg
   mapM_ (selectFields fns) ps
@@ -1471,12 +1604,11 @@ describeField verbosity my_flags pkgarg fields expand_pkgroot = do
 
 checkConsistency :: Verbosity -> [Flag] -> IO ()
 checkConsistency verbosity my_flags = do
-  (db_stack, _, _) <-
-         getPkgDatabases verbosity False{-modify-} True{-use user-}
-                                   True{-use cache-} True{-expand vars-}
-                                   my_flags
-         -- although check is not a modify command, we do need to use the user
-         -- db, because we may need it to verify package deps.
+  (db_stack, GhcPkg.DbOpenReadOnly, _) <-
+    getPkgDatabases verbosity GhcPkg.DbOpenReadOnly
+      True{-use user-} True{-use cache-} True{-expand vars-} my_flags
+      -- although check is not a modify command, we do need to use the user
+      -- db, because we may need it to verify package deps.
 
   let simple_output = FlagSimpleOutput `elem` my_flags
 
@@ -1930,10 +2062,6 @@ reportError s = do hFlush stdout; hPutStrLn stderr s
 dieForcible :: String -> IO ()
 dieForcible s = die (s ++ " (use --force to override)")
 
-my_head :: String -> [a] -> a
-my_head s []      = error s
-my_head _ (x : _) = x
-
 -----------------------------------------
 -- Cut and pasted from ghc/compiler/main/SysTools