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

7 files changed, 600 insertions, 157 deletions

diff --git a/libraries/base/GHC/IO/Handle.hs b/libraries/base/GHC/IO/Handle.hs
index ec376cb8d4..256f802c3d 100644
--- a/libraries/base/GHC/IO/Handle.hs
+++ b/libraries/base/GHC/IO/Handle.hs
@@ -26,12 +26,14 @@ module GHC.IO.Handle (
 
    mkFileHandle, mkDuplexHandle,
 
-   hFileSize, hSetFileSize, hIsEOF, hLookAhead,
+   hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead,
    hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,
    hFlush, hFlushAll, hDuplicate, hDuplicateTo,
 
    hClose, hClose_help,
 
+   LockMode(..), hLock, hTryLock,
+
    HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
    SeekMode(..), hSeek, hTell,
 
@@ -54,6 +56,8 @@ import GHC.IO.Encoding
 import GHC.IO.Buffer
 import GHC.IO.BufferedIO ( BufferedIO )
 import GHC.IO.Device as IODevice
+import GHC.IO.Handle.FD
+import GHC.IO.Handle.Lock
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
 import GHC.IO.Handle.Text
@@ -162,6 +166,15 @@ hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do
              return False
 
 -- ---------------------------------------------------------------------------
+-- isEOF
+
+-- | The computation 'isEOF' is identical to 'hIsEOF',
+-- except that it works only on 'stdin'.
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+-- ---------------------------------------------------------------------------
 -- Looking ahead
 
 -- | Computation 'hLookAhead' returns the next character from the handle
diff --git a/libraries/base/GHC/IO/Handle/FD.hs b/libraries/base/GHC/IO/Handle/FD.hs
index b2c971c908..e988b25c9f 100644
--- a/libraries/base/GHC/IO/Handle/FD.hs
+++ b/libraries/base/GHC/IO/Handle/FD.hs
@@ -18,13 +18,13 @@
 module GHC.IO.Handle.FD ( 
   stdin, stdout, stderr,
   openFile, openBinaryFile, openFileBlocking,
-  mkHandleFromFD, fdToHandle, fdToHandle',
-  isEOF
+  mkHandleFromFD, fdToHandle, fdToHandle', handleToFd
  ) where
 
 import GHC.Base
 import GHC.Show
 import Data.Maybe
+import Data.Typeable
 import Foreign.C.Types
 import GHC.MVar
 import GHC.IO
@@ -32,7 +32,6 @@ import GHC.IO.Encoding
 import GHC.IO.Device as IODevice
 import GHC.IO.Exception
 import GHC.IO.IOMode
-import GHC.IO.Handle
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
 import qualified GHC.IO.FD as FD
@@ -105,15 +104,6 @@ foreign import ccall unsafe "__hscore_setmode"
 #endif
 
 -- ---------------------------------------------------------------------------
--- isEOF
-
--- | The computation 'isEOF' is identical to 'hIsEOF',
--- except that it works only on 'stdin'.
-
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-
--- ---------------------------------------------------------------------------
 -- Opening and Closing Files
 
 addFilePathToIOError :: String -> FilePath -> IOException -> IOException
@@ -199,7 +189,7 @@ openFile' filepath iomode binary non_blocking = do
 
 
 -- ---------------------------------------------------------------------------
--- Converting file descriptors to Handles
+-- Converting file descriptors from/to Handles
 
 mkHandleFromFD
    :: FD.FD
@@ -283,6 +273,21 @@ fdToHandle fdint = do
    mkHandleFromFD fd fd_type fd_str iomode False{-non-block-} 
                   Nothing -- bin mode
 
+-- | Turn an existing Handle into a file descriptor. This function throws an
+-- IOError if the Handle does not reference a file descriptor.
+handleToFd :: Handle -> IO FD.FD
+handleToFd h = case h of
+  FileHandle _ mv -> do
+    Handle__{haDevice = dev} <- readMVar mv
+    case cast dev of
+      Just fd -> return fd
+      Nothing -> throwErr "not a file descriptor"
+  DuplexHandle{} -> throwErr "not a file handle"
+  where
+    throwErr msg = ioException $ IOError (Just h)
+      InappropriateType "handleToFd" msg Nothing Nothing
+
+
 -- ---------------------------------------------------------------------------
 -- Are files opened by default in text or binary mode, if the user doesn't
 -- specify?
diff --git a/libraries/base/GHC/IO/Handle/Lock.hsc b/libraries/base/GHC/IO/Handle/Lock.hsc
new file mode 100644
index 0000000000..1da0308cdf
--- /dev/null
+++ b/libraries/base/GHC/IO/Handle/Lock.hsc
@@ -0,0 +1,162 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE InterruptibleFFI #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module GHC.IO.Handle.Lock (
+    FileLockingNotSupported(..)
+  , LockMode(..)
+  , hLock
+  , hTryLock
+  ) where
+
+#include "HsBaseConfig.h"
+
+#if HAVE_FLOCK
+
+#include <sys/file.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+
+#elif defined(mingw32_HOST_OS)
+
+#if defined(i386_HOST_ARCH)
+## define WINDOWS_CCONV stdcall
+#elif defined(x86_64_HOST_ARCH)
+## define WINDOWS_CCONV ccall
+#else
+# error Unknown mingw32 arch
+#endif
+
+#include <windows.h>
+
+import Data.Bits
+import Data.Function
+import Foreign.C.Error
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import GHC.IO.Exception
+import GHC.IO.FD
+import GHC.IO.Handle.FD
+import GHC.Ptr
+import GHC.Real
+import GHC.Windows
+
+#endif
+
+import Data.Functor
+import GHC.Base
+import GHC.Exception
+import GHC.IO.Handle.Types
+import GHC.Show
+
+-- | Exception thrown by 'hLock' on non-Windows platforms that don't support
+-- 'flock'.
+data FileLockingNotSupported = FileLockingNotSupported
+  deriving Show
+
+instance Exception FileLockingNotSupported
+
+-- | Indicates a mode in which a file should be locked.
+data LockMode = SharedLock | ExclusiveLock
+
+-- | If a 'Handle' references a file descriptor, attempt to lock contents of the
+-- underlying file in appropriate mode. If the file is already locked in
+-- incompatible mode, this function blocks until the lock is established. The
+-- lock is automatically released upon closing a 'Handle'.
+--
+-- Things to be aware of:
+--
+-- 1) This function may block inside a C call. If it does, in order to be able
+-- to interrupt it with asynchronous exceptions and/or for other threads to
+-- continue working, you MUST use threaded version of the runtime system.
+--
+-- 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,
+-- hence all of their caveats also apply here.
+--
+-- 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this
+-- function throws 'FileLockingNotImplemented'. We deliberately choose to not
+-- provide fcntl based locking instead because of its broken semantics.
+--
+-- @since 4.10.0.0
+hLock :: Handle -> LockMode -> IO ()
+hLock h mode = void $ lockImpl h "hLock" mode True
+
+-- | Non-blocking version of 'hLock'.
+--
+-- @since 4.10.0.0
+hTryLock :: Handle -> LockMode -> IO Bool
+hTryLock h mode = lockImpl h "hTryLock" mode False
+
+----------------------------------------
+
+#if HAVE_FLOCK
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  let flags = cmode .|. (if block then 0 else #{const LOCK_NB})
+  fix $ \retry -> c_flock fd flags >>= \case
+    0 -> return True
+    _ -> getErrno >>= \errno -> if
+      | not block && errno == eWOULDBLOCK -> return False
+      | errno == eINTR -> retry
+      | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing
+  where
+    cmode = case mode of
+      SharedLock    -> #{const LOCK_SH}
+      ExclusiveLock -> #{const LOCK_EX}
+
+foreign import ccall interruptible "flock"
+  c_flock :: CInt -> CInt -> IO CInt
+
+#elif defined(mingw32_HOST_OS)
+
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl h ctx mode block = do
+  FD{fdFD = fd} <- handleToFd h
+  wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd
+  allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do
+    fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0
+    let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})
+    -- We want to lock the whole file without looking up its size to be
+    -- consistent with what flock does. According to documentation of LockFileEx
+    -- "locking a region that goes beyond the current end-of-file position is
+    -- not an error", however e.g. Windows 10 doesn't accept maximum possible
+    -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by
+    -- leaving the highest bit set to 0.
+    fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x7fffffff ovrlpd >>= \case
+      True  -> return True
+      False -> getLastError >>= \err -> if
+        | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False
+        | err == #{const ERROR_OPERATION_ABORTED} -> retry
+        | otherwise -> failWith ctx err
+  where
+    sizeof_OVERLAPPED = #{size OVERLAPPED}
+
+    cmode = case mode of
+      SharedLock    -> 0
+      ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}
+
+-- https://msdn.microsoft.com/en-us/library/aa297958.aspx
+foreign import ccall unsafe "_get_osfhandle"
+  c_get_osfhandle :: CInt -> IO HANDLE
+
+-- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx
+foreign import WINDOWS_CCONV interruptible "LockFileEx"
+  c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL
+
+#else
+
+-- | No-op implementation.
+lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool
+lockImpl _ _ _ _ = throwIO FileLockingNotSupported
+
+#endif
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 2649173a41..f00fb8768e 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -244,6 +244,7 @@ Library
         GHC.IO.Handle
         GHC.IO.Handle.FD
         GHC.IO.Handle.Internals
+        GHC.IO.Handle.Lock
         GHC.IO.Handle.Text
         GHC.IO.Handle.Types
         GHC.IO.IOMode
diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac
index 426e5715e4..af041a7ad5 100644
--- a/libraries/base/configure.ac
+++ b/libraries/base/configure.ac
@@ -30,7 +30,7 @@ dnl ** check for full ANSI header (.h) files
 AC_HEADER_STDC
 
 # check for specific header (.h) files that we are interested in
-AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h poll.h sys/epoll.h sys/event.h sys/eventfd.h])
+AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/file.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h poll.h sys/epoll.h sys/event.h sys/eventfd.h])
 
 # Enable large file support. Do this before testing the types ino_t, off_t, and
 # rlim_t, because it will affect the result of that test.
@@ -69,6 +69,12 @@ if test "$ac_cv_header_poll_h" = yes && test "$ac_cv_func_poll" = yes; then
   AC_DEFINE([HAVE_POLL], [1], [Define if you have poll support.])
 fi
 
+#flock
+AC_CHECK_FUNCS([flock])
+if test "$ac_cv_header_sys_file_h" = yes && test "$ac_cv_func_flock" = yes; then
+  AC_DEFINE([HAVE_FLOCK], [1], [Define if you have flock support.])
+fi
+
 # unsetenv
 AC_CHECK_FUNCS([unsetenv])
 
diff --git a/libraries/ghc-boot/GHC/PackageDb.hs b/libraries/ghc-boot/GHC/PackageDb.hs
index 9b2889f4cf..7f8468aada 100644
--- a/libraries/ghc-boot/GHC/PackageDb.hs
+++ b/libraries/ghc-boot/GHC/PackageDb.hs
@@ -1,6 +1,16 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 -----------------------------------------------------------------------------
 -- |
@@ -43,6 +53,12 @@ module GHC.PackageDb (
        BinaryStringRep(..),
        DbUnitIdModuleRep(..),
        emptyInstalledPackageInfo,
+       PackageDbLock,
+       lockPackageDb,
+       unlockPackageDb,
+       DbMode(..),
+       DbOpenMode(..),
+       isDbOpenReadMode,
        readPackageDbForGhc,
        readPackageDbForGhcPkg,
        writePackageDb
@@ -53,6 +69,8 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS.Char8
 import qualified Data.ByteString.Lazy as BS.Lazy
 import qualified Data.ByteString.Lazy.Internal as BS.Lazy (defaultChunkSize)
+import qualified Data.Foldable as F
+import qualified Data.Traversable as F
 import Data.Binary as Bin
 import Data.Binary.Put as Bin
 import Data.Binary.Get as Bin
@@ -62,6 +80,9 @@ import System.FilePath
 import System.IO
 import System.IO.Error
 import GHC.IO.Exception (IOErrorType(InappropriateType))
+#if MIN_VERSION_base(4,10,0)
+import GHC.IO.Handle.Lock
+#endif
 import System.Directory
 
 
@@ -185,12 +206,96 @@ emptyInstalledPackageInfo =
        trusted            = False
   }
 
+-- | Represents a lock of a package db.
+newtype PackageDbLock = PackageDbLock
+#if MIN_VERSION_base(4,10,0)
+  Handle
+#else
+  ()  -- no locking primitives available in base < 4.10
+#endif
+
+-- | Acquire an exclusive lock related to package DB under given location.
+lockPackageDb :: FilePath -> IO PackageDbLock
+
+-- | Release the lock related to package DB.
+unlockPackageDb :: PackageDbLock -> IO ()
+
+#if MIN_VERSION_base(4,10,0)
+
+-- | Acquire a lock of given type related to package DB under given location.
+lockPackageDbWith :: LockMode -> FilePath -> IO PackageDbLock
+lockPackageDbWith mode file = do
+  -- We are trying to open the lock file and then lock it. Thus the lock file
+  -- needs to either exist or we need to be able to create it. Ideally we
+  -- would not assume that the lock file always exists in advance. When we are
+  -- dealing with a package DB where we have write access then if the lock
+  -- file does not exist then we can create it by opening the file in
+  -- read/write mode. On the other hand if we are dealing with a package DB
+  -- where we do not have write access (e.g. a global DB) then we can only
+  -- open in read mode, and the lock file had better exist already or we're in
+  -- trouble. So for global read-only DBs on platforms where we must lock the
+  -- DB for reading then we will require that the installer/packaging has
+  -- included the lock file.
+  --
+  -- Thus the logic here is to first try opening in read-only mode (to handle
+  -- global read-only DBs) and if the file does not exist then try opening in
+  -- read/write mode to create the lock file. If either succeed then lock the
+  -- file. IO exceptions (other than the first open attempt failing due to the
+  -- file not existing) simply propagate.
+  catchJust
+    (\e -> if isDoesNotExistError e then Just () else Nothing)
+    (lockFileOpenIn ReadMode)
+    (const $ lockFileOpenIn ReadWriteMode)
+  where
+    lock = file <.> "lock"
+
+    lockFileOpenIn io_mode = bracketOnError
+      (openBinaryFile lock io_mode)
+      hClose
+      -- If file locking support is not available, ignore the error and proceed
+      -- normally. Without it the only thing we lose on non-Windows platforms is
+      -- the ability to safely issue concurrent updates to the same package db.
+      $ \hnd -> do hLock hnd mode `catch` \FileLockingNotSupported -> return ()
+                   return $ PackageDbLock hnd
+
+lockPackageDb = lockPackageDbWith ExclusiveLock
+unlockPackageDb (PackageDbLock hnd) = hClose hnd
+
+-- MIN_VERSION_base(4,10,0)
+#else
+
+lockPackageDb _file = return $ PackageDbLock ()
+unlockPackageDb _lock = return ()
+
+-- MIN_VERSION_base(4,10,0)
+#endif
+
+-- | Mode to open a package db in.
+data DbMode = DbReadOnly | DbReadWrite
+
+-- | 'DbOpenMode' holds a value of type @t@ but only in 'DbReadWrite' mode.  So
+-- it is like 'Maybe' but with a type argument for the mode to enforce that the
+-- mode is used consistently.
+data DbOpenMode (mode :: DbMode) t where
+  DbOpenReadOnly  ::      DbOpenMode 'DbReadOnly t
+  DbOpenReadWrite :: t -> DbOpenMode 'DbReadWrite t
+
+deriving instance Functor (DbOpenMode mode)
+deriving instance F.Foldable (DbOpenMode mode)
+deriving instance F.Traversable (DbOpenMode mode)
+
+isDbOpenReadMode :: DbOpenMode mode t -> Bool
+isDbOpenReadMode = \case
+  DbOpenReadOnly    -> True
+  DbOpenReadWrite{} -> False
+
 -- | Read the part of the package DB that GHC is interested in.
 --
 readPackageDbForGhc :: RepInstalledPackageInfo a b c d e f g =>
                        FilePath -> IO [InstalledPackageInfo a b c d e f g]
 readPackageDbForGhc file =
-    decodeFromFile file getDbForGhc
+  decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case
+    (pkgs, DbOpenReadOnly) -> return pkgs
   where
     getDbForGhc = do
       _version    <- getHeader
@@ -205,9 +310,14 @@ readPackageDbForGhc file =
 -- is not defined in this package. This is because ghc-pkg uses Cabal types
 -- (and Binary instances for these) which this package does not depend on.
 --
-readPackageDbForGhcPkg :: Binary pkgs => FilePath -> IO pkgs
-readPackageDbForGhcPkg file =
-    decodeFromFile file getDbForGhcPkg
+-- If we open the package db in read only mode, we get its contents. Otherwise
+-- we additionally receive a PackageDbLock that represents a lock on the
+-- database, so that we can safely update it later.
+--
+readPackageDbForGhcPkg :: Binary pkgs => FilePath -> DbOpenMode mode t ->
+                          IO (pkgs, DbOpenMode mode PackageDbLock)
+readPackageDbForGhcPkg file mode =
+    decodeFromFile file mode getDbForGhcPkg
   where
     getDbForGhcPkg = do
       _version    <- getHeader
@@ -221,9 +331,10 @@ readPackageDbForGhcPkg file =
 -- | Write the whole of the package DB, both parts.
 --
 writePackageDb :: (Binary pkgs, RepInstalledPackageInfo a b c d e f g) =>
-                  FilePath -> [InstalledPackageInfo a b c d e f g] -> pkgs -> IO ()
+                  FilePath -> [InstalledPackageInfo a b c d e f g] ->
+                  pkgs -> IO ()
 writePackageDb file ghcPkgs ghcPkgPart =
-    writeFileAtomic file (runPut putDbForGhcPkg)
+  writeFileAtomic file (runPut putDbForGhcPkg)
   where
     putDbForGhcPkg = do
         putHeader
@@ -279,11 +390,28 @@ headerMagic = BS.Char8.pack "\0ghcpkg\0"
 
 -- | Feed a 'Get' decoder with data chunks from a file.
 --
-decodeFromFile :: FilePath -> Get a -> IO a
-decodeFromFile file decoder =
-    withBinaryFile file ReadMode $ \hnd ->
-      feed hnd (runGetIncremental decoder)
+decodeFromFile :: FilePath -> DbOpenMode mode t -> Get pkgs ->
+                  IO (pkgs, DbOpenMode mode PackageDbLock)
+decodeFromFile file mode decoder = case mode of
+  DbOpenReadOnly -> do
+  -- When we open the package db in read only mode, there is no need to acquire
+  -- shared lock on non-Windows platform because we update the database with an
+  -- atomic rename, so readers will always see the database in a consistent
+  -- state.
+#if MIN_VERSION_base(4,10,0) && defined(mingw32_HOST_OS)
+    bracket (lockPackageDbWith SharedLock file) unlockPackageDb $ \_ -> do
+#endif
+      (, DbOpenReadOnly) <$> decodeFileContents
+  DbOpenReadWrite{} -> do
+    -- When we open the package db in read/write mode, acquire an exclusive lock
+    -- on the database and return it so we can keep it for the duration of the
+    -- update.
+    bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do
+      (, DbOpenReadWrite lock) <$> decodeFileContents
   where
+    decodeFileContents = withBinaryFile file ReadMode $ \hnd ->
+      feed hnd (runGetIncremental decoder)
+
     feed hnd (Partial k)  = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize
                                if BS.null chunk
                                  then feed hnd (k Nothing)
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