diff options
author | Andrzej Rybczak <electricityispower@gmail.com> | 2017-03-02 11:26:09 -0500 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-03-02 12:25:06 -0500 |
commit | 5f7b45a51f3736ad5a5046ba2fe4155446a2c467 (patch) | |
tree | 62136502a10415788ff853af3c95e048e561413f | |
parent | 55f6353f7adc4d947aac8dfea227fdc4f54ac6d7 (diff) | |
download | haskell-5f7b45a51f3736ad5a5046ba2fe4155446a2c467.tar.gz |
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
-rw-r--r-- | compiler/main/Packages.hs | 29 | ||||
-rw-r--r-- | 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 5f1a7d5d30..06678317e7 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 dd49180615..c42feecb22 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, |