ghc-pkg: Consider .conf files when computing package db mtime

We can no longer use the mtime of the containing directory since it now
contains a lock file in addition to the .cache and .conf files.

Fixes #13375.

Test Plan: Validate on Windows

Reviewers: austin, arybczak

Subscribers: rwbarton, thomie

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

1 files changed, 21 insertions, 64 deletions

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index c5ecbf23e1..ed73c2960b 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -832,14 +832,15 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
          Right fs
            | not use_cache -> ignore_cache (const $ return ())
            | otherwise -> do
-              tdir     <- getModificationTime path
               e_tcache <- tryIO $ getModificationTime cache
               case e_tcache of
                 Left ex -> do
                   whenReportCacheErrors $
                     if isDoesNotExistError ex
                       then
-                        when (verbosity >= Verbose) $ do
+                        -- It's fine if the cache is not there as long as the
+                        -- database is empty.
+                        when (not $ null confs) $ do
                             warn ("WARNING: cache does not exist: " ++ cache)
                             warn ("ghc will fail to read this package db. " ++
                                   recacheAdvice)
@@ -848,21 +849,13 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                         warn "ghc will fail to read this package db."
                   ignore_cache (const $ return ())
                 Right tcache -> do
-                  let compareTimestampToCache file =
-                          when (verbosity >= Verbose) $ do
-                              tFile <- getModificationTime file
-                              compareTimestampToCache' file tFile
-                      compareTimestampToCache' file tFile = do
-                          let rel = case tcache `compare` tFile of
-                                    LT -> " (NEWER than cache)"
-                                    GT -> " (older than cache)"
-                                    EQ -> " (same as cache)"
-                          warn ("Timestamp " ++ show tFile
-                             ++ " for " ++ file ++ rel)
                   when (verbosity >= Verbose) $ do
                       warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
-                      compareTimestampToCache' path tdir
-                  if tcache >= tdir
+                  -- If any of the .conf files is newer than package.cache, we
+                  -- assume that cache is out of date.
+                  cache_outdated <- (`anyM` confs) $ \conf ->
+                    (tcache <) <$> getModificationTime conf
+                  if not cache_outdated
                       then do
                           when (verbosity > Normal) $
                              infoLn ("using cache: " ++ cache)
@@ -873,18 +866,27 @@ readParseDatabase verbosity mb_user_conf mode use_cache path
                               warn ("WARNING: cache is out of date: " ++ cache)
                               warn ("ghc will see an old view of this " ++
                                     "package db. " ++ recacheAdvice)
-                          ignore_cache compareTimestampToCache
+                          ignore_cache $ \file -> do
+                            when (verbosity >= Verbose) $ do
+                              tFile <- getModificationTime file
+                              let rel = case tcache `compare` tFile of
+                                    LT -> " (NEWER than cache)"
+                                    GT -> " (older than cache)"
+                                    EQ -> " (same as cache)"
+                              warn ("Timestamp " ++ show tFile
+                                ++ " for " ++ file ++ rel)
             where
+                 confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
+
                  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 cache) mode
-                     let confs = filter (".conf" `isSuffixOf`) fs
-                         doFile f = do checkTime f
+                     let doFile f = do checkTime f
                                        parseSingletonPackageConf verbosity f
-                     pkgs <- mapM doFile $ map (path </>) confs
+                     pkgs <- mapM doFile confs
                      mkPackageDB pkgs lock
 
                  -- We normally report cache errors for read-only commands,
@@ -1215,16 +1217,6 @@ updateDBCache verbosity db = do
       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.
-  -- 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
-
   case packageDbLock db of
     GhcPkg.DbOpenReadWrite lock -> GhcPkg.unlockPackageDb lock
 
@@ -2180,38 +2172,3 @@ removeFileSafe fn =
 -- absolute path.
 absolutePath :: FilePath -> IO FilePath
 absolutePath path = return . normalise . (</> path) =<< getCurrentDirectory
-
-
-{- Note [writeAtomic leaky abstraction]
-GhcPkg.writePackageDb calls writeAtomic, which first writes to a temp file,
-and then moves the tempfile to its final destination. This all happens in the
-same directory (package.conf.d).
-Moving a file doesn't change its modification time, but it *does* change the
-modification time of the directory it is placed in. Since we compare the
-modification time of the cache file to that of the directory it is in to
-decide whether the cache is out-of-date, it will be instantly out-of-date
-after creation, if the renaming takes longer than the smallest time difference
-that the getModificationTime can measure.
-
-The solution we opt for is a "touch" of the cache file right after it is
-created. This resets the modification time of the cache file and the directory
-to the current time.
-
-Other possible solutions:
-  * backdate the modification time of the directory to the modification time
-    of the cachefile. This is what we used to do on posix platforms. An
-    observer of the directory would see the modification time of the directory
-    jump back in time. Not nice, although in practice probably not a problem.
-    Also note that a cross-platform implementation of setModificationTime is
-    currently not available.
-  * set the modification time of the cache file to the modification time of
-    the directory (instead of the curent time). This could also work,
-    given that we are the only ones writing to this directory. It would also
-    require a high-precision getModificationTime (lower precision times get
-    rounded down it seems), or the cache would still be out-of-date.
-  * change writeAtomic to create the tempfile outside of the target file's
-    directory.
-  * create the cachefile outside of the package.conf.d directory in the first
-    place. But there are tests and there might be tools that currently rely on
-    the package.conf.d/package.cache format.
--}