Commit 5f7b45a5 authored by Andrzej Rybczak's avatar Andrzej Rybczak Committed by Ben Gamari

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
parent 55f6353f
......@@ -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
......
......@@ -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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment