[commit: ghc] master: Properly acquire locks on not yet existing package databases (5f7b45a)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/5f7b45a51f3736ad5a5046ba2fe4155446a2c467/ghc

>---------------------------------------------------------------

commit 5f7b45a51f3736ad5a5046ba2fe4155446a2c467
Author: Andrzej Rybczak <electricityispower at gmail.com>
Date:   Thu Mar 2 11:26:09 2017 -0500

    Properly acquire locks on not yet existing package databases
    
    Reviewers: austin, bgamari, angerman
    
    Reviewed By: bgamari, angerman
    
    Subscribers: angerman, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3259


>---------------------------------------------------------------

5f7b45a51f3736ad5a5046ba2fe4155446a2c467
 compiler/main/Packages.hs | 29 +++++++++++++++++++++++++++--
 utils/ghc-pkg/Main.hs     | 23 +++++++++++++++--------
 2 files changed, 42 insertions(+), 10 deletions(-)

diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index 5f1a7d5..0667831 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -549,8 +549,33 @@ readPackageConfig dflags conf_file = do
   where
     readDirStylePackageConfig conf_dir = do
       let filename = conf_dir </> "package.cache"
-      debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
-      readPackageDbForGhc filename
+      cache_exists <- doesFileExist filename
+      if cache_exists
+        then do
+          debugTraceMsg dflags 2 $ text "Using binary package database:"
+                                    <+> text filename
+          readPackageDbForGhc filename
+        else do
+          -- If there is no package.cache file, we check if the database is not
+          -- empty by inspecting if the directory contains any .conf file. If it
+          -- does, something is wrong and we fail. Otherwise we assume that the
+          -- database is empty.
+          debugTraceMsg dflags 2 $ text "There is no package.cache in"
+                               <+> text conf_dir
+                                <> text ", checking if the database is empty"
+          db_empty <- all (not . isSuffixOf ".conf")
+                   <$> getDirectoryContents conf_dir
+          if db_empty
+            then do
+              debugTraceMsg dflags 3 $ text "There are no .conf files in"
+                                   <+> text conf_dir <> text ", treating"
+                                   <+> text "package database as empty"
+              return []
+            else do
+              throwGhcExceptionIO $ InstallationError $
+                "there is no package.cache in " ++ conf_dir ++
+                " even though package database is not empty"
+
 
     -- Single-file style package dbs have been deprecated for some time, but
     -- it turns out that Cabal was using them in one place. So this is a
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index dd49180..c42feec 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -807,7 +807,10 @@ readParseDatabase :: forall mode t. Verbosity
 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 [] =<< F.mapM (const $ GhcPkg.lockPackageDb path) mode
+  = do lock <- F.forM mode $ \_ -> do
+         createDirectoryIfMissing True path
+         GhcPkg.lockPackageDb cache
+       mkPackageDB [] lock
   | otherwise
   = do e <- tryIO $ getDirectoryContents path
        case e of
@@ -828,17 +831,17 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
          Right fs
            | not use_cache -> ignore_cache (const $ return ())
            | otherwise -> do
-              let cache = path </> cachefilename
               tdir     <- getModificationTime path
               e_tcache <- tryIO $ getModificationTime cache
               case e_tcache of
                 Left ex -> do
                   whenReportCacheErrors $
                     if isDoesNotExistError ex
-                      then do
-                        warn ("WARNING: cache does not exist: " ++ cache)
-                        warn ("ghc will fail to read this package db. " ++
-                              recacheAdvice)
+                      then
+                        when (verbosity >= Verbose) $ do
+                            warn ("WARNING: cache does not exist: " ++ cache)
+                            warn ("ghc will fail to read this package db. " ++
+                                  recacheAdvice)
                       else do
                         warn ("WARNING: cache cannot be read: " ++ show ex)
                         warn "ghc will fail to read this package db."
@@ -876,7 +879,7 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                      -- 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
+                     lock <- F.mapM (const $ GhcPkg.lockPackageDb cache) mode
                      let confs = filter (".conf" `isSuffixOf`) fs
                          doFile f = do checkTime f
                                        parseSingletonPackageConf verbosity f
@@ -888,6 +891,8 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                  whenReportCacheErrors = when $ verbosity > Normal
                    || verbosity >= Normal && GhcPkg.isDbOpenReadMode mode
   where
+    cache = path </> cachefilename
+
     recacheAdvice
       | Just (user_conf, True) <- mb_user_conf, path == user_conf
       = "Use 'ghc-pkg recache --user' to fix."
@@ -1012,7 +1017,9 @@ tryReadParseOldFileStyleDatabase verbosity mb_user_conf
               locationAbsolute = path_abs
             }
          else do
-           lock <- F.mapM (const $ GhcPkg.lockPackageDb path_dir) mode
+           lock <- F.forM mode $ \_ -> do
+             createDirectoryIfMissing True path_dir
+             GhcPkg.lockPackageDb $ path_dir </> cachefilename
            return $ Just PackageDB {
                location         = path,
                locationAbsolute = path_abs,